comsrf.f90

来自「CCSM Research Tools: Community Atmospher」· F90 代码 · 共 480 行 · 第 1/2 页

    trefmxav (:,:) = inf
    trefmnav (:,:) = inf

    asdirice (:,:) = inf
    aldirice (:,:) = inf
    asdifice (:,:) = inf
    aldifice (:,:) = inf
    tsice (:,:) = inf
!
! Sub-surface temperatures
!
    if (plevmx > 9) then
       write(6,*)'INITIALIZE_COMSRF: Cannot handle more than 9 subsurface levels'
       call endrun ()
    endif
    do k=1,plevmx
       write(unit=tsnam(k),fmt='(''TS'',i1,''     '')') k
    end do

    do c = begchunk,endchunk
       srfflx_state2d(c)%asdir  (:) = 0.
       srfflx_state2d(c)%asdif  (:) = 0.
       srfflx_state2d(c)%aldir  (:) = 0.
       srfflx_state2d(c)%aldif  (:) = 0.
       srfflx_state2d(c)%lwup   (:) = 0.
       srfflx_state2d(c)%lhf    (:) = 0.
       srfflx_state2d(c)%shf    (:) = 0.
       srfflx_state2d(c)%cflx   (:,:) = 0.
       srfflx_state2d(c)%wsx    (:) = 0.
       srfflx_state2d(c)%wsy    (:) = 0.
       srfflx_state2d(c)%tref   (:) = 0.
       srfflx_state2d(c)%ts     (:) = 0.

       surface_state2d(c)%tbot  (:) = 0.
       surface_state2d(c)%zbot  (:) = 0.
       surface_state2d(c)%ubot  (:) = 0.
       surface_state2d(c)%vbot  (:) = 0.
       surface_state2d(c)%qbot  (:) = 0.
       surface_state2d(c)%pbot  (:) = 0.
       surface_state2d(c)%thbot (:) = 0.
       surface_state2d(c)%tssub (:,:) = 0.
    end do
    
    call srfflx_parm_reset (srfflx_parm2d)

    return
  end subroutine initialize_comsrf

!===========================================================================
  subroutine srfflx_parm_reset(parm)
!---------------------------------------------------------------------------
!
! Purpose:
! Zero fluxes that are update by land,ocn,ice sub processes
!
! Method:
!
! Author: John Truesdale
!
!-----------------------------------------------------------------------
    implicit none
    type(srfflx_parm), intent(inout),dimension(begchunk:endchunk)  :: parm ! Parameterization tendencies
    integer c        ! chunk index

    call t_startf ('srfflx_rst_st')
    do c=begchunk,endchunk
       parm(c)%asdir(:) = 0.
       parm(c)%asdif(:) = 0.
       parm(c)%aldir(:) = 0.
       parm(c)%aldif(:) = 0.
       parm(c)%lwup (:) = 0.
       parm(c)%lhf  (:) = 0.
       parm(c)%shf  (:) = 0.
       parm(c)%cflx (:,:) = 0.
       parm(c)%wsx  (:) = 0.
       parm(c)%wsy  (:) = 0.
       parm(c)%tref (:) = 0.
       parm(c)%ts   (:) = 0.
    end do
    call t_stopf ('srfflx_rst_st')
    return
  end subroutine srfflx_parm_reset

  subroutine srfflx_state_reset(state)
!-----------------------------------------------------------------------
!
! Purpose:
! Zero fluxes that are update by land,ocn,ice sub processes
!
! Method:
!
! Author: John Truesdale
!
!-----------------------------------------------------------------------
    implicit none
    type(srfflx_state), dimension(begchunk:endchunk), intent(inout)  :: state   ! srfflx state variables
    integer c        ! chunk index

    call t_startf ('srfflx_rst_st')
    do c=begchunk,endchunk
       state(c)%asdir(:) = 0.
       state(c)%asdif(:) = 0.
       state(c)%aldir(:) = 0.
       state(c)%aldif(:) = 0.
       state(c)%lwup(:) = 0.
       state(c)%lhf(:) = 0.
       state(c)%shf(:) = 0.
       state(c)%cflx(:,:) = 0.
       state(c)%wsx(:) = 0.
       state(c)%wsy(:) = 0.
       state(c)%tref(:) = 0.
       state(c)%ts(:) = 0.
    end do
    call t_stopf ('srfflx_rst_st')

    return
  end subroutine srfflx_state_reset

  subroutine update_srf_fluxes(state, parm, frac)
!-----------------------------------------------------------------------
!
! Purpose:
! update surface fluxes
!
! Method:
!
! Author: John Truesdale
!
!------------------------------Arguments--------------------------------

    use physconst, only: stebol
    use phys_grid, only: get_ncols_p

    implicit none

    type(srfflx_parm), intent(inout)  :: parm(begchunk:endchunk)
    type(srfflx_state), intent(inout) :: state(begchunk:endchunk)
    real(r8) :: frac(pcols,begchunk:endchunk)
!
! Local workspace
!
    integer :: i,c,m     ! longitude, chunk, constituent indices
    integer :: ncol      ! number of longitudes this chunk

    call t_startf ('update_srf_st')
    do c=begchunk,endchunk
       ncol = get_ncols_p(c)
       do i=1,ncol
          if (frac(i,c) > 0.) then
             state(c)%asdir(i) = state(c)%asdir(i) + parm(c)%asdir(i) * frac(i,c)
             state(c)%asdif(i) = state(c)%asdif(i) + parm(c)%asdif(i) * frac(i,c)
             state(c)%aldir(i) = state(c)%aldir(i) + parm(c)%aldir(i) * frac(i,c)
             state(c)%aldif(i) = state(c)%aldif(i) + parm(c)%aldif(i) * frac(i,c)
             state(c)%lwup(i)  = state(c)%lwup(i)  + parm(c)%lwup(i)  * frac(i,c)
             state(c)%lhf(i)   = state(c)%lhf(i)   + parm(c)%lhf(i)   * frac(i,c)
             state(c)%shf(i)   = state(c)%shf(i)   + parm(c)%shf(i)   * frac(i,c)
             state(c)%wsx(i)   = state(c)%wsx(i)   + parm(c)%wsx(i)   * frac(i,c)
             state(c)%wsy(i)   = state(c)%wsy(i)   + parm(c)%wsy(i)   * frac(i,c)
             state(c)%tref(i)  = state(c)%tref(i)  + parm(c)%tref(i)  * frac(i,c) 

!
! if we are calculating ts for a non-fractional grid box (ie all land or
! all ocean or all ice then use the ts given by the parameterization) 
! otherwise calculate ts based on the grid averaged lwup 
!
!jt pull this code out after bit for bit testing
!jt
          if (frac(i,c) == 1.) then  
             state(c)%ts(i) = state(c)%ts(i) + &
                  parm(c)%ts(i) * frac(i,c) 
          else
             state(c)%ts(i)=sqrt(sqrt(state(c)%lwup(i)/stebol))
          end if

             do m=1,pcnst+pnats
                state(c)%cflx(i,m) = state(c)%cflx(i,m) + parm(c)%cflx(i,m) * frac(i,c)
             end do
          end if
       end do
    end do
!
! zero srfflx parameterization
!
    call t_stopf ('update_srf_st')
    call srfflx_parm_reset(parm)

    return
  end subroutine update_srf_fluxes

  subroutine update_srf_fractions
!-----------------------------------------------------------------------
!
! Purpose:
! update surface fluxes
!
! Method:
!
! Author: John Truesdale
!
!-----------------------------------------------------------------------
    use phys_grid, only: get_ncols_p

    implicit none

    integer :: j,i,ncol

! Make land ocean and ice concentrations consistant - after advnce
! is called the ice fraction will change due to interpolation in
! iceint so we must reapportion the ocean fraction accordingly.
!
! 1) land fraction is taken as given
! 2) ice percentage is allowed to occupy what is not land
!    ice percentage may be modified so that the sum of land and ice
!        fractions is <= 1.
! 3) ocean fraction is determined last.  Ocean occupies whatever is 
!    not land or ice
!
    call t_startf ('update_srf_st')
    do j=begchunk,endchunk
       ncol = get_ncols_p(j)
       do i=1,ncol
! fix inconsistancies between ice and land fractions, use land as truth
	if ((icefrac(i,j).gt.1.0.or.icefrac(i,j).lt.0.) .or. &
	   (landfrac(i,j).gt.1.0.or.landfrac(i,j).lt.0.)) then
	   write(6,*)'COMSRF: Error in orography fractions'
	   write(6,*)' Encountered a fraction greater than 1 or less than 0.'
	   write(6,*)' Calling endrun'
	   call endrun
	end if	
          if (icefrac(i,j)+landfrac(i,j) > 1.0_r8) then
             icefrac(i,j)=1.0_r8-landfrac(i,j)	
          end if
          ocnfrac(i,j)=1.0_r8-landfrac(i,j)-icefrac(i,j)
       end do
    end do
    call t_stopf ('update_srf_st')
    return
  end subroutine update_srf_fractions
end module comsrf