UPP (develop)
Loading...
Searching...
No Matches
CALRCH.f
Go to the documentation of this file.
1
24!-----------------------------------------------------------------------
29!-----------------------------------------------------------------------
30
31 SUBROUTINE calrch(EL,RICHNO)
32
33!
34 use vrbls3d, only: pmid, q, t, uh, vh, zmid, q2
35 use masks, only: vtm
36 use params_mod, only: h10e5, capa, d608,h1, epsq2, g, beta
37 use ctlblk_mod, only: jsta, jend, spval, lm1, jsta_m, jend_m, im, &
38 jsta_2l, jend_2u, lm, &
39 ista, iend, ista_m, iend_m, ista_2l, iend_2u
40 use gridspec_mod, only: gridtype
41!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
42 implicit none
43!
44! DECLARE VARIABLES.
45!
46 REAL,intent(in) :: EL(ista_2l:iend_2u,jsta_2l:jend_2u,LM)
47 REAL,intent(inout) :: RICHNO(ista_2l:iend_2u,jsta_2l:jend_2u,LM)
48!
49 REAL, ALLOCATABLE :: THV(:,:,:)
50 integer I,J,L,IW,IE
51 real APE,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP,RDZKL, &
52 dthvkl,dukl,dvkl,ri,ct,cs
53! real APE,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP,DZKL,RDZKL,Q2KL,QROOT,ELKL, &
54! ELKLSQ,DTHVKL,DUKL,DVKL,RI,CT,CS
55!
56!
57!*************************************************************************
58! START CALRCH HERE.
59!
60 ALLOCATE ( thv(ista_2l:iend_2u,jsta_2l:jend_2u,lm) )
61! INITIALIZE ARRAYS.
62!
63!$omp parallel do
64 DO l = 1,lm
65 DO j=jsta,jend
66 DO i=ista,iend
67 richno(i,j,l)=spval
68 ENDDO
69 ENDDO
70 ENDDO
71!
72! COMPUTE VIRTUAL POTENTIAL TEMPERATURE.
73!
74!$omp parallel do private(i,j,ape)
75 DO l=lm,1,-1
76 DO j=jsta,jend
77 DO i=ista,iend
78 ape = (h10e5/pmid(i,j,l))**capa
79 thv(i,j,l) = (q(i,j,l)*d608+h1)*t(i,j,l)*ape
80 ENDDO
81 ENDDO
82 ENDDO
83!
84! COMPUTE GRADIENT RICHARDSON NUMBER AS CODED IN ETA MODEL
85! SUBROUTINE PROFQ2.F. OUTER LOOP OVER THE VERTICAL.
86! INTTER LOOP OVER THE HORIZONTAL.
87!
88!!$omp parallel do private(i,j,l,ie,iw,cs,ct,dthvkl,dukl,dvkl, &
89!!$omp& rdzkl,ri,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp)
90 DO l = 1,lm1
91!
92 if(gridtype /= 'A')THEN
93 call exch(vtm(1,jsta_2l,l))
94 call exch(uh(1,jsta_2l,l))
95 call exch(vh(1,jsta_2l,l))
96 call exch(vtm(1,jsta_2l,l+1))
97 call exch(uh(1,jsta_2l,l+1))
98 call exch(vh(1,jsta_2l,l+1))
99 end if
100
101 DO j=jsta_m,jend_m
102 DO i=ista_m,iend_m
103!
104 IF(gridtype == 'A')THEN
105 uhkl = uh(i,j,l)
106 ulkl = uh(i,j,l+1)
107 vhkl = vh(i,j,l)
108 vlkl = vh(i,j,l+1)
109 ELSE IF(gridtype == 'E')THEN
110 ie = i+mod(j+1,2)
111 iw = i+mod(j+1,2)-1
112!
113! WE NEED (U,V) WINDS AT A MASS POINT. FOUR POINT
114! AVERAGE (U,V) WINDS TO MASS POINT. NORMALIZE FOUR
115! POINT AVERAGE BY THE ACTUAL NUMBER OF (U,V) WINDS
116! USED IN THE AVERAGING. VTM=1 IF WIND POINT IS
117! ABOVE GROUND. VTM=0 IF BELOW GROUND.
118!
119 wndsl = vtm(i,j-1,l)+vtm(iw,j,l)+vtm(ie,j,l)+vtm(i,j+1,l)
120 wndslp = vtm(i,j-1,l+1) + vtm(iw,j,l+1)+ &
121 vtm(ie,j,l+1) + vtm(i,j+1,l+1)
122 IF(wndsl == 0. .OR. wndslp == 0.) cycle
123 uhkl = (uh(i,j-1,l)+uh(iw,j,l)+uh(ie,j,l)+uh(i,j+1,l))/wndsl
124 ulkl = (uh(i,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j,l+1)+ &
125 uh(i,j+1,l+1))/wndslp
126 vhkl = (vh(i,j-1,l)+vh(iw,j,l)+vh(ie,j,l)+vh(i,j+1,l))/wndsl
127 vlkl = (vh(i,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j,l+1)+ &
128 vh(i,j+1,l+1))/wndslp
129 ELSE IF(gridtype == 'B')THEN
130 ie = i
131 iw = i-1
132 uhkl = (uh(iw,j-1,l)+uh(iw,j,l)+uh(ie,j-1,l)+uh(i,j,l))/4.0
133 ulkl = (uh(iw,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j-1,l+1)+ &
134 uh(i,j,l+1))/4.0
135 vhkl = (vh(iw,j-1,l)+vh(iw,j,l)+vh(ie,j-1,l)+vh(i,j,l))/4.0
136 vlkl = (vh(iw,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j-1,l+1)+ &
137 vh(i,j,l+1))/4.0
138 END IF
139
140 rdzkl = 1.0 / (zmid(i,j,l)-zmid(i,j,l+1))
141
142! Q2KL = MAX(Q2(I,J,L),0.00001)
143! QROOT = SQRT(Q2KL)
144! ELKL = EL(I,J,L)
145! ELKL = MAX(ELKL,EPSQ2)
146! ELKLSQ = ELKL*ELKL
147
148 dthvkl = thv(i,j,l)-thv(i,j,l+1)
149 dukl = (uhkl-ulkl) * rdzkl
150 dvkl = (vhkl-vlkl) * rdzkl
151 cs = dukl*dukl + dvkl*dvkl
152!
153! COMPUTE GRADIENT RICHARDSON NUMBER.
154!
155 IF(cs <= 1.e-8) THEN
156!
157! WIND SHEAR IS VANISHINGLY SMALL - SO SET RICHARDSON
158! NUMBER TO POST PROCESSOR SPECIAL VALUE.
159!
160 richno(i,j,l) = spval
161!
162 ELSE
163!
164! WIND SHEAR LARGE ENOUGH TO USE RICHARDSON NUMBER.
165!
166 ct = -1.*g*beta*dthvkl*rdzkl
167 ri = -ct/cs
168 richno(i,j,l) = ri
169 ENDIF
170!
171 ENDDO
172 ENDDO
173 ENDDO ! end of l loop
174!
175 DEALLOCATE (thv)
176! END OF ROUTINE.
177!
178 RETURN
179 END
180
subroutine calrch(el, richno)
Subroutine that computes GRD RCH number.
Definition CALRCH.f:32
subroutine exch(a)
exch() Subroutine that exchanges one halo row.
Definition EXCH.f:27