phylmd/CV_routines/cv_feed.f

module cv_feed_m

  implicit none

contains

  SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, &
       tnk, qnk, gznk, plcl)

    use cv_param

    ! Purpose: CONVECTIVE FEED

    ! inputs:
    integer, intent(in):: len, nd
    real, intent(in):: t(len, nd)
    real, intent(in):: q(len, nd), qs(len, nd), p(len, nd)
    real hm(len, nd), gz(len, nd)

    ! outputs:
    integer iflag(len)
    integer, intent(out):: nk(len), icb(len), icbmax
    real tnk(len), qnk(len), gznk(len), plcl(len)

    ! local variables:
    integer i, k
    integer ihmin(len)
    real work(len)
    real pnk(len), qsnk(len), rh(len), chi(len)

    !-------------------------------------------------------------------
    ! --- Find level of minimum moist static energy
    ! --- If level of minimum moist static energy coincides with
    ! --- or is lower than minimum allowable parcel origin level,
    ! --- set iflag to 6.
    !-------------------------------------------------------------------

    do i=1, len
       work(i)=1.0e12
       ihmin(i)=nl
    end do
    do k=2, nlp
       do i=1, len
          if ((hm(i, k) < work(i)).and. &
               (hm(i, k) < hm(i, k-1)))then
             work(i)=hm(i, k)
             ihmin(i)=k
          endif
       end do
    end do
    do i=1, len
       ihmin(i) = min(ihmin(i), nlm)
       if (ihmin(i) <= minorig) iflag(i)=6
    end do

    !-------------------------------------------------------------------
    ! --- Find that model level below the level of minimum moist static
    ! --- energy that has the maximum value of moist static energy
    !-------------------------------------------------------------------

    do i=1, len
       work(i)=hm(i, minorig)
       nk(i)=minorig
    end do
    do k=minorig+1, nl
       do i=1, len
          if ((hm(i, k) > work(i)).and.(k <= ihmin(i)))then
             work(i)=hm(i, k)
             nk(i)=k
          endif
       end do
    end do
    !-------------------------------------------------------------------
    ! --- Check whether parcel level temperature and specific humidity
    ! --- are reasonable
    !-------------------------------------------------------------------
    do i=1, len
       if (((t(i, nk(i)) < 250.0).or. &
            (q(i, nk(i)) <= 0.0).or. &
            (p(i, ihmin(i)) < 400.0)).and. &
            (iflag(i) == 0))iflag(i)=7
    end do
    !-------------------------------------------------------------------
    ! --- Calculate lifted condensation level of air at parcel origin level
    ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV., 1980)
    !-------------------------------------------------------------------
    do i=1, len
       tnk(i)=t(i, nk(i))
       qnk(i)=q(i, nk(i))
       gznk(i)=gz(i, nk(i))
       pnk(i)=p(i, nk(i))
       qsnk(i)=qs(i, nk(i))

       rh(i)=qnk(i)/qsnk(i)
       rh(i)=min(1.0, rh(i))
       chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
       plcl(i)=pnk(i)*(rh(i)**chi(i))
       if (((plcl(i) < 200.0).or.(plcl(i) >= 2000.0)) &
            .and.(iflag(i) == 0))iflag(i)=8
    end do
    !-------------------------------------------------------------------
    ! --- Calculate first level above lcl (=icb)
    !-------------------------------------------------------------------
    do i=1, len
       icb(i)=nlm
    end do

    do k=minorig, nl
       do i=1, len
          if ((k >= (nk(i)+1)).and.(p(i, k) < plcl(i))) &
               icb(i)=min(icb(i), k)
       end do
    end do

    do i=1, len
       if ((icb(i) >= nlm).and.(iflag(i) == 0))iflag(i)=9
    end do

    ! Compute icbmax.

    icbmax=2
    do i=1, len
       icbmax=max(icbmax, icb(i))
    end do

  end SUBROUTINE cv_feed

end module cv_feed_m
1	module cv_feed_m
2
3	implicit none
4
5	contains
6
7	SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, &
8	tnk, qnk, gznk, plcl)
9
10	use cv_param
11
12	! Purpose: CONVECTIVE FEED
13
14	! inputs:
15	integer, intent(in):: len, nd
16	real, intent(in):: t(len, nd)
17	real, intent(in):: q(len, nd), qs(len, nd), p(len, nd)
18	real hm(len, nd), gz(len, nd)
19
20	! outputs:
21	integer iflag(len)
22	integer, intent(out):: nk(len), icb(len), icbmax
23	real tnk(len), qnk(len), gznk(len), plcl(len)
24
25	! local variables:
26	integer i, k
27	integer ihmin(len)
28	real work(len)
29	real pnk(len), qsnk(len), rh(len), chi(len)
30
31	!-------------------------------------------------------------------
32	! --- Find level of minimum moist static energy
33	! --- If level of minimum moist static energy coincides with
34	! --- or is lower than minimum allowable parcel origin level,
35	! --- set iflag to 6.
36	!-------------------------------------------------------------------
37
38	do i=1, len
39	work(i)=1.0e12
40	ihmin(i)=nl
41	end do
42	do k=2, nlp
43	do i=1, len
44	if ((hm(i, k) < work(i)).and. &
45	(hm(i, k) < hm(i, k-1)))then
46	work(i)=hm(i, k)
47	ihmin(i)=k
48	endif
49	end do
50	end do
51	do i=1, len
52	ihmin(i) = min(ihmin(i), nlm)
53	if (ihmin(i) <= minorig) iflag(i)=6
54	end do
55
56	!-------------------------------------------------------------------
57	! --- Find that model level below the level of minimum moist static
58	! --- energy that has the maximum value of moist static energy
59	!-------------------------------------------------------------------
60
61	do i=1, len
62	work(i)=hm(i, minorig)
63	nk(i)=minorig
64	end do
65	do k=minorig+1, nl
66	do i=1, len
67	if ((hm(i, k) > work(i)).and.(k <= ihmin(i)))then
68	work(i)=hm(i, k)
69	nk(i)=k
70	endif
71	end do
72	end do
73	!-------------------------------------------------------------------
74	! --- Check whether parcel level temperature and specific humidity
75	! --- are reasonable
76	!-------------------------------------------------------------------
77	do i=1, len
78	if (((t(i, nk(i)) < 250.0).or. &
79	(q(i, nk(i)) <= 0.0).or. &
80	(p(i, ihmin(i)) < 400.0)).and. &
81	(iflag(i) == 0))iflag(i)=7
82	end do
83	!-------------------------------------------------------------------
84	! --- Calculate lifted condensation level of air at parcel origin level
85	! --- (Within 0.2% of formula of Bolton, MON. WEA. REV., 1980)
86	!-------------------------------------------------------------------
87	do i=1, len
88	tnk(i)=t(i, nk(i))
89	qnk(i)=q(i, nk(i))
90	gznk(i)=gz(i, nk(i))
91	pnk(i)=p(i, nk(i))
92	qsnk(i)=qs(i, nk(i))
93
94	rh(i)=qnk(i)/qsnk(i)
95	rh(i)=min(1.0, rh(i))
96	chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
97	plcl(i)=pnk(i)(rh(i)*chi(i))
98	if (((plcl(i) < 200.0).or.(plcl(i) >= 2000.0)) &
99	.and.(iflag(i) == 0))iflag(i)=8
100	end do
101	!-------------------------------------------------------------------
102	! --- Calculate first level above lcl (=icb)
103	!-------------------------------------------------------------------
104	do i=1, len
105	icb(i)=nlm
106	end do
107
108	do k=minorig, nl
109	do i=1, len
110	if ((k >= (nk(i)+1)).and.(p(i, k) < plcl(i))) &
111	icb(i)=min(icb(i), k)
112	end do
113	end do
114
115	do i=1, len
116	if ((icb(i) >= nlm).and.(iflag(i) == 0))iflag(i)=9
117	end do
118
119	! Compute icbmax.
120
121	icbmax=2
122	do i=1, len
123	icbmax=max(icbmax, icb(i))
124	end do
125
126	end SUBROUTINE cv_feed
127
128	end module cv_feed_m