nfw.f90

集合卡尔曼滤波(EnKF) 数据同化方法可以避免了EKF 中协方差演变方程预报过程中出现的计算不准确和关于协方差矩阵的大量数据的存储问题,最主要的是可以有效的控制估计误差方差的增长,改善预报的效果。

    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_put_var_double(ncid, varid, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_put_var_double', name, status)
    end if
  end subroutine nfw_put_var_double

  subroutine nfw_get_var_int(fname, ncid, varid, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_get_var_int(ncid, varid, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_get_var_int', name, status)
    end if
  end subroutine nfw_get_var_int

  subroutine nfw_get_var_double(fname, ncid, varid, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    real(8) :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_get_var_double(ncid, varid, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_get_var_double', name, status)
    end if
  end subroutine nfw_get_var_double

  subroutine nfw_put_vara_int(fname, ncid, varid, start, count, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: start(*)
    integer :: count(*)
    integer :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_put_vara_int(ncid, varid, start, count, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_put_vara_int', name, status)
    end if
  end subroutine nfw_put_vara_int

  subroutine nfw_put_vara_double(fname, ncid, varid, start, count, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: start(*)
    integer :: count(*)
    real(8) :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_put_vara_double(ncid, varid, start, count, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_put_vara_double', name, status)
    end if
  end subroutine nfw_put_vara_double

  subroutine nfw_get_vara_int(fname, ncid, varid, start, count, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: start(*)
    integer :: count(*)
    integer :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_get_vara_int(ncid, varid, start, count, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_get_vara_int', name, status)
    end if
  end subroutine nfw_get_vara_int

  subroutine nfw_get_vara_double(fname, ncid, varid, start, count, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: start(*)
    integer :: count(*)
    real(8) :: v(*)
    character*(NF_MAX_NAME) :: name
    integer :: status

    status = nf_get_vara_double(ncid, varid, start, count, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_get_vara_double', name, status)
    end if
  end subroutine nfw_get_vara_double

  subroutine nfw_get_att_double(fname, ncid, varid, attname, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    real(8) :: v(*)
    character*(*) :: attname
    character*(NF_MAX_NAME) :: varname
    integer :: status

    status = nf_get_att_double(ncid, varid, attname, v)
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_get_att_double', varname, attname, status)
    end if
  end subroutine nfw_get_att_double

  subroutine nfw_get_att_int(fname, ncid, varid, attname, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    integer :: v(*)
    character*(*) :: attname
    character*(NF_MAX_NAME) :: varname
    integer :: status

    status = nf_get_att_int(ncid, varid, attname, v)
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_get_att_int', varname, attname, status)
    end if
  end subroutine nfw_get_att_int

  subroutine nfw_put_att_text(fname, ncid, varid, attname, len, text)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    character*(*) :: attname
    integer :: len
    character*(*) :: text
    integer :: status
    character*(NF_MAX_NAME) :: varname

    status = nf_put_att_text(ncid, varid, attname, len, trim(text))
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_put_att_text', varname, attname, status)
    end if
  end subroutine nfw_put_att_text

  subroutine nfw_put_att_int(fname, ncid, varid, attname, type, len, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    character*(*) :: attname
    integer :: type
    integer :: len
    integer :: v(*)
    integer :: status
    character*(NF_MAX_NAME) :: varname

    status = nf_put_att_int(ncid, varid, attname, type, len, v)
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_put_att_int', varname, attname, status)
    end if
  end subroutine nfw_put_att_int

  subroutine nfw_put_att_real(fname, ncid, varid, attname, type, len, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    character*(*) :: attname
    integer :: type
    integer :: len
    real :: v(*)
    integer :: status
    character*(NF_MAX_NAME) :: varname

    status = nf_put_att_real(ncid, varid, attname, type, len, v)
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_put_att_real', varname, attname, status)
    end if
  end subroutine nfw_put_att_real

  subroutine nfw_put_att_double(fname, ncid, varid, attname, type, len, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    character*(*) :: attname
    integer :: type
    integer :: len
    real(8) :: v(*)
    integer :: status
    character*(NF_MAX_NAME) :: varname

    status = nf_put_att_double(ncid, varid, attname, type, len, v)
    if (status /= 0) then
       if (varid /= nf_global) then
          call nfw_inq_varname(fname, ncid, varid, varname)
       else
          varname = 'NF_GLOBAL'
       end if
       call quit3(fname, 'nf_put_att_double', varname, attname, status)
    end if
  end subroutine nfw_put_att_double

! Derived subroutines

  ! Reads the first record only
  subroutine nfw_get_var_double_firstrecord(fname, ncid, varid, v)
    character*(*) :: fname
    integer :: ncid
    integer :: varid
    real(8) :: v(*)
    integer :: ndims
    integer :: unlimdimid
    integer :: dimids(NF_MAX_VAR_DIMS)
    integer :: dimlen(NF_MAX_VAR_DIMS)
    integer :: dstart(NF_MAX_VAR_DIMS)
    integer :: i
    character*(NF_MAX_NAME) :: name
    integer :: status

    call nfw_inq_varndims(fname, ncid, varid, ndims)
    call nfw_inq_vardimid(fname, ncid, varid, dimids)
    call nfw_inq_unlimdim(fname, ncid, unlimdimid)
    
    do i = 1, ndims
       call nfw_inq_dimlen(fname, ncid, dimids(i), dimlen(i))
       dstart(i) = 1
    end do

    ! check size of v
    if (dimids(ndims) == unlimdimid) then
       dimlen(ndims) = 1 ! 1 record only
    end if

    status = nf_get_vara_double(ncid, varid, dstart, dimlen, v)
    if (status /= 0) then
       call nfw_inq_varname(fname, ncid, varid, name)
       call quit2(fname, 'nf_get_vara_double', name, status)
    end if
  end subroutine nfw_get_var_double_firstrecord

end module nfw_mod