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	guez	103	module cv_feed_m
2	guez	52
3	guez	103	implicit none
4	guez	52
5	guez	103	contains
6	guez	52
7	guez	103	SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, &
8			tnk, qnk, gznk, plcl)
9	guez	52
10	guez	103	use cv_param
11	guez	52
12	guez	103	! Purpose: CONVECTIVE FEED
13	guez	52
14	guez	103	! 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	guez	52
20	guez	103	! 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	guez	52
25	guez	103	! 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	guez	52	work(i)=1.0e12
40			ihmin(i)=nl
41	guez	103	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	guez	52
56	guez	103	!-------------------------------------------------------------------
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	guez	52	nk(i)=minorig
64	guez	103	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	guez	52	icb(i)=nlm
106	guez	103	end do
107	guez	52
108	guez	103	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