clm2d_return.f90

来自「CLM集合卡曼滤波数据同化算法」· F90 代码 · 共 225 行

  SUBROUTINE clm2d_return (lon ,lat)

!=======================================================================
!      Source file: clm2d_return.f90
! Original version: Yongjiu Dai, September 15, 1999
!
!=======================================================================

      USE enkfpar_module
      use clmpar_module
      USE clmtc_module
      USE clmtv_module
      USE miscell_module
      USE clm2d_module

      IMPLICIT NONE
      
      Integer, INTENT(in) :: &
            lon,   &! atm number of longitudes
            lat     ! atm number of latitudes
      !Local
      Integer  i, j, k, l, m, ii
      real  weight  ! subgrid weight
 
! ----------------------------------------------------------------------
! need to initialize 2-d fields to zero for subgrid averaging, but
! only for land points because other surface models may have already
! calculated fields for non-land points.

      do j = 1, lat
         do i = 1, lon
            if(oroxy(i,j)>0.)then
               shxy   (i,j) = 0.
               lhxy   (i,j) = 0.
               cfxy (i,1,j) = 0.
               cfxy (i,2,j) = 0.
               tauxxy (i,j) = 0.
               tauyxy (i,j) = 0.
               tsxy   (i,j) = 0.
               trefxy (i,j) = 0.
               lwupxy (i,j) = 0.
               asdirxy(i,j) = 0.
               asdifxy(i,j) = 0.
               aldirxy(i,j) = 0.
               aldifxy(i,j) = 0.
               scv2xy (i,j) = 0.
            else
               shxy   (i,j) = -999.
               lhxy   (i,j) = -999.
               cfxy (i,1,j) = -999.
               cfxy (i,2,j) = -999.
               tauxxy (i,j) = -999.
               tauyxy (i,j) = -999.
               tsxy   (i,j) = -999.
               trefxy (i,j) = -999.
               lwupxy (i,j) = -999.
               asdirxy(i,j) = -999.
               asdifxy(i,j) = -999.
               aldirxy(i,j) = -999.
               aldifxy(i,j) = -999.
               scv2xy (i,j) = -999.
            endif
         end do
      end do

! map fields from subgrid vector, with length [kpt], to
! [lon] x [lat] surface, weighting by subgrid fraction.
! for each land point on [lon] x [lat] surface, process
! [ktile] subgrid points. if the subgrid point is not valid, a
! dummy index to the subgrid vector is used and the weight is zero.

      do l = 1, lpt            !land pnt index for lon x lat surface
         i = ixy(l)            !longitude index
         j = jxy(l)            !latitude index
         do m = 1, ktile(l)
            k = kvec(l,m)         !clm subgrid vector index
            weight = wsg2g(l,m)   !subgrid weights
            if(weight > 0.)then
               shxy   (i,j) = shxy   (i,j) + fsena  (k)*weight
               lhxy   (i,j) = lhxy   (i,j) + lfevpa (k)*weight 
               cfxy (i,1,j) = cfxy (i,1,j) + fevpa  (k)*weight
               tauxxy (i,j) = tauxxy (i,j) + taux   (k)*weight
               tauyxy (i,j) = tauyxy (i,j) + tauy   (k)*weight
               tsxy   (i,j) = tsxy   (i,j) + trad   (k)*weight
               trefxy (i,j) = trefxy (i,j) + tref   (k)*weight   
               lwupxy (i,j) = lwupxy (i,j) + olrg   (k)*weight
               scv2xy (i,j) = scv2xy (i,j) + scv    (k)*weight
               asdirxy(i,j) = asdirxy(i,j) + alb(1,1,k)*weight
               asdifxy(i,j) = asdifxy(i,j) + alb(1,2,k)*weight
               aldirxy(i,j) = aldirxy(i,j) + alb(2,1,k)*weight
               aldifxy(i,j) = aldifxy(i,j) + alb(2,2,k)*weight
            end if
         end do
      end do

! ----------------------------------------------------------------------
! same as above but for history tape. set non-land fields to zero.
! ----------------------------------------------------------------------

      do j = 1, lat
         do i = 1, lon
            if(oroxy(i,j) > 0.)then
               tgxy    (i,j) = 0.
               fsnoxy  (i,j) = 0.
               sigfxy  (i,j) = 0.
               tlsunxy  (i,j) = 0.
               tlshaxy  (i,j) = 0.
               ldewxy  (i,j) = 0.
               sagxy   (i,j) = 0.
               snowdpxy(i,j) = 0.

               do ii = 1, msl
                  soitemxy (i,j,ii) = 0.
                  soiliqxy (i,j,ii) = 0.
                  soiicexy (i,j,ii) = 0.
               enddo

               fsenlxy (i,j) = 0.
               fevplxy (i,j) = 0.
               etrxy   (i,j) = 0.
               fsengxy (i,j) = 0.
               fevpgxy (i,j) = 0.
               fgrndxy (i,j) = 0.
               rsurxy  (i,j) = 0.
               rnofxy  (i,j) = 0.

               rstxy   (i,j) = 0.
               assimxy (i,j) = 0.
               respcxy (i,j) = 0.

               sabvxy  (i,j) = 0.
               sabgxy  (i,j) = 0.
               sabvgxy (i,j) = 0.
               flwdsxy (i,j) = 0.
            else
               tgxy    (i,j) = -999.
               fsnoxy  (i,j) = -999.
               sigfxy  (i,j) = -999.
               tlsunxy (i,j) = -999.
               tlshaxy (i,j) = -999.
               ldewxy  (i,j) = -999.
               sagxy   (i,j) = -999.
               snowdpxy(i,j) = -999.

               do ii = 1, msl
                  soitemxy (i,j,ii) = -999.
                  soiliqxy (i,j,ii) = -999.
                  soiicexy (i,j,ii) = -999.
               enddo

               fsenlxy (i,j) = -999.
               fevplxy (i,j) = -999.
               etrxy   (i,j) = -999.
               fsengxy (i,j) = -999.
               fevpgxy (i,j) = -999.
               fgrndxy (i,j) = -999.
               rsurxy  (i,j) = -999.
               rnofxy  (i,j) = -999.

               rstxy   (i,j) = -999.
               assimxy (i,j) = -999.
               respcxy (i,j) = -999.

               sabvxy  (i,j) = -999.
               sabgxy  (i,j) = -999.
               sabvgxy (i,j) = -999.
               flwdsxy (i,j) = -999.
            endif
         end do
      end do

      do l = 1, lpt
         i = ixy(l)
         j = jxy(l)
         do m = 1, ktile(l)
            k = kvec(l,m)
            weight = wsg2g(l,m)

! as different number of layer for soil (10 layers) and lake (6 layers)
! some state variables for lake are assigned to 0 (see clm_main.f90), 
! so we should deduct the lake variables in the following averaging. 
! We did not do in the current code,
! please pay attention for the cases including the lake tiles.
 
            if (weight > 0.)then

                tgxy    (i,j) = tgxy    (i,j) + tg    (k) * weight
                fsnoxy  (i,j) = fsnoxy  (i,j) + fsno  (k) * weight
                sigfxy  (i,j) = sigfxy  (i,j) + sigf  (k) * weight
                tlsunxy (i,j) = tlsunxy (i,j) + tlsun (k) * weight
                tlshaxy (i,j) = tlshaxy (i,j) + tlsha (k) * weight
                ldewxy  (i,j) = ldewxy  (i,j) + ldew  (k) * weight
                sagxy   (i,j) = sagxy   (i,j) + sag   (k) * weight
                snowdpxy(i,j) = snowdpxy(i,j) + snowdp(k) * weight

                do ii = 1, msl
                soitemxy (i,j,ii) = soitemxy (i,j,ii) + tss (ii,k) * weight
                soiliqxy (i,j,ii) = soiliqxy (i,j,ii) + wliq(ii,k) * weight
                soiicexy (i,j,ii) = soiicexy (i,j,ii) + wice(ii,k) * weight
                enddo

                fsenlxy (i,j) = fsenlxy (i,j) + fsenl (k) * weight
                fevplxy (i,j) = fevplxy (i,j) + fevpl (k) * weight
                etrxy   (i,j) = etrxy   (i,j) + etr   (k) * weight
                fsengxy (i,j) = fsengxy (i,j) + fseng (k) * weight
                fevpgxy (i,j) = fevpgxy (i,j) + fevpg (k) * weight
                fgrndxy (i,j) = fgrndxy (i,j) + fgrnd (k) * weight
                rsurxy  (i,j) = rsurxy  (i,j) + rsur  (k) * weight
                rnofxy  (i,j) = rnofxy  (i,j) + rnof  (k) * weight

                rstxy   (i,j) = rstxy   (i,j) + rst   (k) * weight
                assimxy (i,j) = assimxy (i,j) + assim (k) * weight
                respcxy (i,j) = respcxy (i,j) + respc (k) * weight

                sabvxy  (i,j) = sabvxy  (i,j) + (sabvsun(k)+sabvsha(k)) * weight
                sabgxy  (i,j) = sabgxy  (i,j) + sabg  (k) * weight
                sabvgxy (i,j) = sabvgxy (i,j) + sabvg (k) * weight
                flwdsxy (i,j) = flwdsxy (i,j) + frl   (k) * weight
                print*,frl(k)  
              end if
         end do
      end do

  END SUBROUTINE clm2d_return