slow_bottom_friction.F90 4.77 KB
Newer Older
kbk's avatar
kbk committed
1
!$Id: slow_bottom_friction.F90,v 1.8 2006-03-01 15:54:08 kbk Exp $
gotm's avatar
gotm committed
2 3 4 5
#include "cppdefs.h"
!-----------------------------------------------------------------------
!BOP
!
6
! !ROUTINE: slow_bottom_friction - slow bed friction
hb's avatar
hb committed
7
! \label{sec-slow-bottom-friction}
gotm's avatar
gotm committed
8 9 10 11 12 13
!
! !INTERFACE:
   subroutine slow_bottom_friction
!
! !DESCRIPTION:
!
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
! This routine basically calculates the bed friction, as it would come out
! if the vertically and macro timestep averaged velocity would be used.
! The output of this subroutine is thus $R\sqrt{u^2+v^2}$ on the U-points
! (see variable {\tt ruu}) and on the V-points (see {\tt rvv}) with the
! vertically and macro timestep averaged velocity components on the
! old time step, $u$ and $v$,
! which are in the code denoted by {\tt Ui} and {\tt Vi}, respectively.
! The drag coefficient $R$ is given by eq.\
! (\ref{bottom_vert}) on page \pageref{bottom_vert}.
! The results for the variables {\tt ruu} and {\tt rvv} will then be used
! in the routine {\tt slow\_terms} described on page \pageref{sec-slow-terms}
! for the calculation of the slow terms $S^x_F$ and $S^y_F$, see
! section \ref{SectionVerticalIntegrated}.
!
!
gotm's avatar
gotm committed
29
! !USES:
kbk's avatar
kbk committed
30
   use parameters, only: kappa
gotm's avatar
gotm committed
31
   use domain, only: iimin,iimax,jjmin,jjmax,HU,HV,min_depth,au,av
32 33
   use variables_2d, only: zub,zvb,ru,rv,Uinto,Vinto
   use variables_3d, only: ssuo,ssun,ssvo,ssvn
gotm's avatar
gotm committed
34 35 36 37 38 39 40 41
   IMPLICIT NONE
!
! !INPUT PARAMETERS:
!
! !INPUT/OUTPUT PARAMETERS:
!
! !OUTPUT PARAMETERS:
!
kbk's avatar
kbk committed
42 43 44
! !REVISION HISTORY:
!  Original author(s): Hans Burchard & Karsten Bolding
!
gotm's avatar
gotm committed
45
! !LOCAL VARIABLES:
kbk's avatar
kbk committed
46 47 48
   integer                   :: i,j
   REALTYPE                  :: uloc,vloc,HH
   logical,save              :: first=.true.
49 50 51 52
   REALTYPE                  :: Ui(I2DFIELD)
   REALTYPE                  :: Vi(I2DFIELD)
   REALTYPE                  :: ruu(I2DFIELD)
   REALTYPE                  :: rvv(I2DFIELD)
gotm's avatar
gotm committed
53 54 55 56 57 58 59 60
!EOP
!-----------------------------------------------------------------------
!BOC
#ifdef DEBUG
   integer, save :: Ncall = 0
   Ncall = Ncall+1
   write(debug,*) 'slow_bottom_friction() # ',Ncall
#endif
61 62 63

   do j=jjmin,jjmax
      do i=iimin,iimax
64 65 66 67 68
         if(au(i,j) .ge. 1) then
            Ui(i,j)=Uinto(i,j)/(ssuo(i,j)+HU(i,j))
         else
            Ui(i,j)=_ZERO_
         end if
gotm's avatar
gotm committed
69 70
      end do
   end do
71 72 73
!  need velocity in some halo points as well
   Ui(:,jjmax+1) = Uinto(:,jjmax+1)/(ssuo(:,jjmax+1)+HU(:,jjmax+1))
   Ui(iimin-1,:) = Uinto(iimin-1,:)/(ssuo(iimin-1,:)+HU(iimin-1,:))
gotm's avatar
gotm committed
74

75 76
   do j=jjmin,jjmax
      do i=iimin,iimax
77 78 79 80 81
         if(av(i,j) .ge. 1) then
            Vi(i,j)=Vinto(i,j)/(ssvo(i,j)+HV(i,j))
         else
            Vi(i,j)=_ZERO_
         end if
gotm's avatar
gotm committed
82 83
      end do
   end do
84 85 86
!  need velocity in some halo points as well
   Vi(:,jjmin-1) = Vinto(:,jjmin-1)/(ssvo(:,jjmin-1)+HV(:,jjmin-1))
   Vi(iimax+1,:) = Vinto(iimax+1,:)/(ssvo(iimax+1,:)+HV(iimax+1,:))
gotm's avatar
gotm committed
87 88 89

   do j=jjmin,jjmax
      do i=iimin,iimax
90 91 92 93 94 95 96 97
         if (au(i,j) .ge. 1) then
            HH=max(min_depth,ssun(i,j)+HU(i,j))
            ruu(i,j)=(zub(i,j)+0.5*HH)/zub(i,j)
            if (ruu(i,j) .le. _ONE_) then
               STDERR i,j,ssuo(i,j),' Bottom xfriction coefficient infinite.'
               stop 'slow_bottom_friction()'
            end if
            ruu(i,j)=(kappa/log(ruu(i,j)))**2
gotm's avatar
gotm committed
98 99 100
         end if
      end do
   end do
101

gotm's avatar
gotm committed
102 103
   do j=jjmin,jjmax
      do i=iimin,iimax
104 105 106 107 108 109 110 111
         if (av(i,j) .ge. 1) then
            HH=max(min_depth,ssvn(i,j)+HV(i,j))
            rvv(i,j)=(zvb(i,j)+0.5*HH)/zvb(i,j)
            if (rvv(i,j) .le. _ONE_) then
               STDERR i,j,ssvo(i,j),' Bottom yfriction coefficient infinite.'
               stop 'slow_bottom_friction()'
            end if
            rvv(i,j)=(kappa/log(rvv(i,j)))**2
gotm's avatar
gotm committed
112 113 114 115 116 117
         end if
      end do
   end do

   do j=jjmin,jjmax
      do i=iimin,iimax
118 119
         if (au(i,j) .ge. 1) then
            uloc=Ui(i,j)
kbk's avatar
kbk committed
120 121 122
            vloc=0.25*( Vi(i  ,j  )    &
                       +Vi(i+1,j  )    &
                       +Vi(i  ,j-1)    &
123 124 125 126
                       +Vi(i+1,j-1) )
            ru(i,j)=ruu(i,j)*sqrt(uloc**2+vloc**2)
         else
            ru(i,j)=_ZERO_
kbk's avatar
kbk committed
127
         end if
gotm's avatar
gotm committed
128 129 130 131 132
      end do
   end do

   do j=jjmin,jjmax
      do i=iimin,iimax
133
         if (av(i,j) .ge. 1) then
kbk's avatar
kbk committed
134 135 136
            uloc=0.25*( Ui(i  ,j  )    &
                       +Ui(i-1,j  )    &
                       +Ui(i  ,j+1)    &
137 138 139 140 141
                       +Ui(i-1,j+1) )
            vloc=Vi(i,j)
            rv(i,j)=rvv(i,j)*sqrt(uloc**2+vloc**2)
         else
            rv(i,j)=_ZERO_
kbk's avatar
kbk committed
142
         end if
gotm's avatar
gotm committed
143 144 145 146 147 148 149 150 151 152 153 154 155 156
      end do
   end do

#ifdef DEBUG
   write(debug,*) 'Leaving slow_bottom_friction()'
   write(debug,*)
#endif
   return
   end subroutine slow_bottom_friction
!EOC

!-----------------------------------------------------------------------
! Copyright (C) 2001 - Hans Burchard and Karsten Bolding               !
!-----------------------------------------------------------------------