UPP  001
 All Data Structures Files Functions Pages
TTBLEX.f
1  SUBROUTINE ttblex(TREF,TTBL,ITB,JTB,KARR,PMIDL &
2  ,pl,qq,pp,rdp,the0,sthe,rdthe,thesp &
3  , iptb,ithtb)
4 !FPP$ NOCONCUR R
5 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
6 ! . . .
7 ! SUBPROGRAM: TTBLEX COMPUTES T ALONG A MOIST ADIABAT
8 ! PRGRMMR: BLACK ORG: W/NP2 DATE: ??-??-??
9 !
10 ! ABSTRACT:
11 ! THIS ROUTINE COMPUTES THE TEMPERATURE ALONG A MOIST
12 ! ADIABAT GIVEN THE SATURATION POTENTIAL TEMPERATURE
13 ! AND THE PRESSURE
14 ! .
15 !
16 ! PROGRAM HISTORY LOG:
17 ! ??-??-?? T BLACK - ORIGINATOR
18 ! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D
19 ! 00-01-04 JIM TUCCILLO - MPI VERSION
20 ! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
21 ! 02-01-15 MIKE BALDWIN - WRF VERSION
22 !
23 ! OUTPUT FILES:
24 ! NONE
25 !
26 ! SUBPROGRAMS CALLED:
27 ! UTILITIES:
28 ! NONE
29 !
30 ! ATTRIBUTES:
31 ! LANGUAGE: FORTRAN
32 !----------------------------------------------------------------------
33  use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, me
34 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35  implicit none
36 !----------------------------------------------------------------------
37 
38  integer,intent(in) :: itb,jtb
39  integer,intent(in) :: karr(im,jsta:jend)
40  real,dimension(JTB,ITB),intent(in) :: ttbl
41  real,dimension(IM,JSTA_2L:JEND_2U),intent(in) :: pmidl
42  real,dimension(IM,JSTA_2L:JEND_2U),intent(out) :: tref
43  real,dimension(IM,jsta:jend),intent(out) :: qq,pp
44  real,dimension(IM,jsta:jend),intent(in) :: thesp
45  real,dimension(ITB), intent(in) :: the0,sthe
46  integer,dimension(IM,jsta:jend),intent(out) :: iptb,ithtb
47  real,intent(in) :: pl,rdp,rdthe
48 
49 !
50  integer i,j,ith,ip,iptbk
51  real pk,tpk,t00k,t10k,t01k,t11k,bthe00k,sthe00k,bthk,sthk, &
52  tthk,bthe10k,sthe10k
53 !-----------------------------------------------------------------------
54 !$omp parallel do &
55 !$omp& private(i,j,bthe00k,bthe10k,bthk,ip,iptbk,ith,pk,sthe00k,sthe10k,&
56 !$omp& sthk,t00k,t01k,t10k,t11k,tpk,tthk)
57  DO j=jsta,jend
58  DO i=1,im
59  IF(karr(i,j) > 0) THEN
60 !--------------SCALING PRESSURE & TT TABLE INDEX------------------------
61  pk = pmidl(i,j)
62  tpk = (pk-pl)*rdp
63  qq(i,j) = tpk-aint(tpk)
64  iptb(i,j) = int(tpk) + 1
65 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
66  IF(iptb(i,j) < 1) THEN
67  iptb(i,j) = 1
68  qq(i,j) = 0.
69  ENDIF
70 !
71  IF(iptb(i,j) >= itb) THEN
72  iptb(i,j) = itb-1
73  qq(i,j) = 0.
74  ENDIF
75 !--------------BASE AND SCALING FACTOR FOR THE--------------------------
76  iptbk = iptb(i,j)
77  bthe00k = the0(iptbk)
78  sthe00k = sthe(iptbk)
79  bthe10k = the0(iptbk+1)
80  sthe10k = sthe(iptbk+1)
81 !--------------SCALING THE & TT TABLE INDEX-----------------------------
82  bthk = (bthe10k-bthe00k)*qq(i,j)+bthe00k
83  sthk = (sthe10k-sthe00k)*qq(i,j)+sthe00k
84  tthk = (thesp(i,j)-bthk)/sthk*rdthe
85  pp(i,j) = tthk-aint(tthk)
86 ! write(1000+me,*)' i=',i,' j=',j,' tthk=',tthk,' thesp=',thesp(i,j) &
87 ! , ' bthk=',bthk,' sthk=',sthk,' rdthe=',rdthe
88 
89  ithtb(i,j) = int(tthk)+1
90 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
91  IF(ithtb(i,j) < 1) THEN
92  ithtb(i,j) = 1
93  pp(i,j) = 0.
94  ENDIF
95 !
96  IF(ithtb(i,j) >= jtb) THEN
97  ithtb(i,j) = jtb-1
98  pp(i,j) = 0.
99  ENDIF
100 !--------------TEMPERATURE AT FOUR SURROUNDING TT TABLE PTS.------------
101  ith = ithtb(i,j)
102  ip = iptb(i,j)
103  t00k = ttbl(ith ,ip )
104  t10k = ttbl(ith+1,ip )
105  t01k = ttbl(ith ,ip+1)
106  t11k = ttbl(ith+1,ip+1)
107 !--------------PARCEL TEMPERATURE-------------------------------------
108  tref(i,j) = (t00k+(t10k-t00k)*pp(i,j)+(t01k-t00k)*qq(i,j) &
109  + (t00k-t10k-t01k+t11k)*pp(i,j)*qq(i,j))
110  ENDIF
111  ENDDO
112  ENDDO
113 !
114  RETURN
115  END SUBROUTINE ttblex
116 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
117 !
118 !-------------------------------------------------------------------------------------
119 !