pkg/fizhi/fizhi_rayleigh.F

7274bff031 Andr*0001 #include "FIZHI_OPTIONS.h"
3768927683 Andr*0002       subroutine rayleigh(myid,pres,pkap,pekap,zsurf,u,v,t,s,im,jm,lm,
                0003      .                                                bi,bj,rfu,rfv,rft)
7274bff031 Andr*0004 C **********************************************************************
                0005 C
                0006 C  PURPOSE
740d8136ce Andr*0007 C     Rayleigh Friction -- Linear Drag (Strong Damping) Above 70 Km
7274bff031 Andr*0008 C
                0009 C  ARGUMENTS   DESCRIPTION
3768927683 Andr*0010 C
                0011 C  INPUT:
7274bff031 Andr*0012 C     MYID .... PROCESS(OR) NUMBER
3768927683 Andr*0013 C     PRES .... MID-LEVEL PRESSURE IN MB
                0014 C     PKAP .... MID-LEVEL PRESSURE ** KAPPA
                0015 C     PEKAP ... EDGE-LEVEL PRESSURE ** KAPPA
                0016 C     ZSURF ... SURFACE ELEVATION IN M
                0017 C     U ....... U-WIND
                0018 C     V ....... V-WIND
                0019 C     TH ...... THETA (ACTUALLY REAL THETA * P0**KAPPA) IN K
                0020 C     S  ...... SPECIFIC HUMIDITY (KG/KG)
                0021 C     IM ...... NUMBER OF LONGITUDE POINTS
                0022 C     JM ...... NUMBER OF LATITUDE  POINTS
                0023 C     LM ...... NUMBER OF VERTICAL  LEVELS
7274bff031 Andr*0024 C     BI ...... X-DIRECTION PROCESSOR INDEX
                0025 C     BJ ...... Y-DIRECTION PROCESSOR INDEX
3768927683 Andr*0026 C  OUTPUT:
                0027 C     RFU ..... U-WIND TENDENCY
                0028 C     RFV ..... V-WIND TENDENCY
                0029 C     RFT ..... THETA  TENDENCY
7274bff031 Andr*0030 C
                0031 C **********************************************************************
                0032
                0033       implicit none
                0034
                0035       integer myid,im,jm,lm,bi,bj
aa1b3f6aa7 Andr*0036       _RL zsurf(im,jm),pres(im,jm,lm),pkap(im,jm,lm)
                0037       _RL pekap(im,jm,lm+1)
3768927683 Andr*0038       _RL u(im,jm,lm),v(im,jm,lm),t(im,jm,lm),s(im,jm,lm)
                0039       _RL rfu(im,jm,lm),rfv(im,jm,lm),rft(im,jm,lm)
7274bff031 Andr*0040
                0041       integer  i,j,L
3768927683 Andr*0042       _RL rf(im,jm,lm)
                0043       _RL z(im,jm,lm)
                0044       _RL dz(im,jm,lm)
740d8136ce Andr*0045       _RL cpog, cpinv, virtcon, getcon, dampcoef
8b150b4af9 Andr*0046 #ifdef ALLOW_DIAGNOSTICS
                0047       logical  diagnostics_is_on
                0048       external diagnostics_is_on
                0049       _RL tmpdiag(im,jm)
                0050 #endif
7274bff031 Andr*0051
                0052 C **********************************************************************
3768927683 Andr*0053 C ****   APPLY RAYLEIGH FRICTION TO WIND (INCLUDE HEATING)           ***
7274bff031 Andr*0054 C **********************************************************************
                0055
3768927683 Andr*0056       cpog = getcon('CP')/getcon('GRAVITY')
7274bff031 Andr*0057       cpinv = 1.0/getcon('CP')
3768927683 Andr*0058       virtcon = getcon('VIRTCON')
740d8136ce Andr*0059       dampcoef = 2./3.
7274bff031 Andr*0060
                0061       do L=1,lm
3768927683 Andr*0062        do j=1,jm
                0063        do i=1,im
                0064         dz(i,j,L) = cpog * (pekap(i,j,L+1)-pekap(i,j,L)) * t(i,j,L) *
                0065      .                (1.+virtcon*s(i,j,L))
                0066        enddo
                0067        enddo
7274bff031 Andr*0068       enddo
                0069
                0070       do j=1,jm
                0071       do i=1,im
3768927683 Andr*0072        z(i,j,lm) = zsurf(i,j) +  0.5 * dz(i,j,lm)
7274bff031 Andr*0073       enddo
                0074       enddo
                0075
3768927683 Andr*0076       do L=lm-1,1,-1
                0077        do j=1,jm
                0078        do i=1,im
                0079         z(i,j,L) = z(i,j,L+1) + 0.5 * (dz(i,j,L)+dz(i,j,L+1))
                0080        enddo
                0081        enddo
7274bff031 Andr*0082       enddo
3768927683 Andr*0083
                0084       do L=1,lm
                0085        do j=1,jm
                0086        do i=1,im
8d9e124bb0 Andr*0087         rf(i,j,L) = dampcoef*(1+tanh((z(i,j,L)-50000.)/5000.))/86400.
3768927683 Andr*0088         rfu(i,j,L) = - rf(i,j,L) * u(i,j,L)
                0089         rfv(i,j,L) = - rf(i,j,L) * v(i,j,L)
                0090         rft(i,j,L) = -(u(i,j,L)*rfu(i,j,L) + v(i,j,L)*rfv(i,j,L) )*cpinv
                0091      .                        /pkap(i,j,L)
                0092        enddo
                0093        enddo
7274bff031 Andr*0094       enddo
                0095
3768927683 Andr*0096 #ifdef ALLOW_DIAGNOSTICS
                0097       do L=1,lm
8b150b4af9 Andr*0098
                0099       if(diagnostics_is_on('RFU     ',myid) ) then
3768927683 Andr*0100        do j=1,jm
                0101        do i=1,im
8b150b4af9 Andr*0102         tmpdiag(i,j) = rfu(i,j,L)*86400
3768927683 Andr*0103        enddo
                0104        enddo
1486b197e2 Andr*0105 C      call diagnostics_fill(tmpdiag,'RFU     ',L,1,3,bi,bj,myid)
8b150b4af9 Andr*0106       endif
3768927683 Andr*0107
8b150b4af9 Andr*0108       if(diagnostics_is_on('RFV     ',myid) ) then
3768927683 Andr*0109        do j=1,jm
                0110        do i=1,im
8b150b4af9 Andr*0111         tmpdiag(i,j) = rfv(i,j,L)*86400
3768927683 Andr*0112        enddo
                0113        enddo
1486b197e2 Andr*0114 C      call diagnostics_fill(tmpdiag,'RFV     ',L,1,3,bi,bj,myid)
8b150b4af9 Andr*0115       endif
3768927683 Andr*0116
8b150b4af9 Andr*0117       if(diagnostics_is_on('RFT     ',myid) ) then
3768927683 Andr*0118        do j=1,jm
                0119        do i=1,im
8b150b4af9 Andr*0120         tmpdiag(i,j) = rft(i,j,L)*86400
3768927683 Andr*0121        enddo
                0122        enddo
1486b197e2 Andr*0123 C      call diagnostics_fill(tmpdiag,'RFT     ',L,1,3,bi,bj,myid)
3768927683 Andr*0124       endif
8b150b4af9 Andr*0125
                0126       enddo
3768927683 Andr*0127 #endif
7274bff031 Andr*0128
                0129       return
                0130       end