File: C:\NOAA\NEMS_11731\src\atmos\gfs\dyn\dozeuv.f

1           subroutine dozeuv(dod,zev,uod,vev,epsedn,epsodn,
2          x                  snnp1ev,snnp1od,ls_node)
3     cc
4           use gfs_dyn_resol_def
5           use gfs_dyn_layout1
6           use gfs_dyn_physcons, rerth => con_rerth
7           implicit none
8     cc
9           real(kind=kind_evod)     dod(len_trio_ls,2)
10           real(kind=kind_evod)     zev(len_trie_ls,2)
11           real(kind=kind_evod)     uod(len_trio_ls,2)
12           real(kind=kind_evod)     vev(len_trie_ls,2)
13     cc
14           real(kind=kind_evod)  epsedn(len_trie_ls)
15           real(kind=kind_evod)  epsodn(len_trio_ls)
16     cc
17           real(kind=kind_evod) snnp1ev(len_trie_ls)
18           real(kind=kind_evod) snnp1od(len_trio_ls)
19     cc
20           integer              ls_node(ls_dim,3)
21     cc
22     !cmr  ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
23     !cmr  ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
24     !cmr  ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
25     cc
26           integer              l,locl,n
27     cc
28           integer              indev,indev1,indev2
29           integer              indod,indod1,indod2
30           integer              inddif
31     cc
32           real(kind=kind_evod) rl
33     cc
34           real(kind=kind_evod) cons0     !constant
35     cc
36           integer              indlsev,jbasev
37           integer              indlsod,jbasod
38     cc
39           include 'function2'
40     cc
41     cc
42     cc......................................................................
43     cc
44     cc
45           cons0 = 0.d0     !constant
46     cc
47     cc
48           do locl=1,ls_max_node
49                   l=ls_node(locl,1)
50              jbasev=ls_node(locl,2)
51     cc
52              vev(indlsev(l,l),1) = cons0     !constant
53              vev(indlsev(l,l),2) = cons0     !constant
54     cc
55     cc
56           enddo
57     cc
58     cc......................................................................
59     cc
60           do locl=1,ls_max_node
61                   l=ls_node(locl,1)
62              jbasev=ls_node(locl,2)
63              jbasod=ls_node(locl,3)
64              indev1 = indlsev(L,L)
65              if (mod(L,2).eq.mod(jcap+1,2)) then
66                 indev2 = indlsev(jcap-1,L)
67              else
68                 indev2 = indlsev(jcap  ,L)
69              endif
70              indod1 = indlsod(l+1,l)
71              inddif = indev1 - indod1
72     cc
73              do indev = indev1 , indev2
74     cc
75                 uod(indev-inddif,1) = -epsodn(indev-inddif)
76          x                              * zev(indev,1)
77     cc
78                 uod(indev-inddif,2) = -epsodn(indev-inddif)
79          x                              * zev(indev,2)
80     cc
81              enddo
82     cc
83           enddo
84     cc
85     cc......................................................................
86     cc
87           do locl=1,ls_max_node
88                   l=ls_node(locl,1)
89              jbasev=ls_node(locl,2)
90              jbasod=ls_node(locl,3)
91              indev1 = indlsev(L,L) + 1
92              if (mod(L,2).eq.mod(jcap+1,2)) then
93                 indev2 = indlsev(jcap+1,L)
94              else
95                 indev2 = indlsev(jcap  ,L)
96              endif
97              indod1 = indlsod(l+1,l)
98              inddif = indev1 - indod1
99     cc
100              do indev = indev1 , indev2
101     cc
102                 vev(indev,1) = epsedn(indev)
103          x                      * dod(indev-inddif,1)
104     cc
105                 vev(indev,2) = epsedn(indev)
106          x                      * dod(indev-inddif,2)
107     cc
108              enddo
109     cc
110           enddo
111     cc
112     cc......................................................................
113     cc
114           do locl=1,ls_max_node
115                   l=ls_node(locl,1)
116              jbasod=ls_node(locl,3)
117              indod1 = indlsod(L+1,L)
118              if (mod(L,2).eq.mod(jcap+1,2)) then
119                 indod2 = indlsod(jcap  ,L)
120              else
121                 indod2 = indlsod(jcap+1,L) - 1
122              endif
123              if ( l .ge. 1 ) then
124                   rl = l
125                 do indod = indod1 , indod2
126     cc             u(l,n)=-i*l*d(l,n)/(n*(n+1))
127     cc
128                    uod(indod,1) = uod(indod,1)
129          1                 + rl * dod(indod,2)
130          2                  / snnp1od(indod)
131     cc
132                    uod(indod,2) = uod(indod,2)
133          1                 - rl * dod(indod,1)
134          2                  / snnp1od(indod)
135     cc
136                 enddo
137              endif
138     cc
139           enddo
140     cc
141     cc......................................................................
142     cc
143           do locl=1,ls_max_node
144                   l=ls_node(locl,1)
145              jbasev=ls_node(locl,2)
146              indev1 = indlsev(L,L)
147              if (mod(L,2).eq.mod(jcap+1,2)) then
148                 indev2 = indlsev(jcap-1,L)
149              else
150                 indev2 = indlsev(jcap  ,L)
151              endif
152              if ( l .ge. 1 ) then
153                   rl = l
154                 do indev = indev1 , indev2
155     cc             u(l,n)=-i*l*d(l,n)/(n*(n+1))
156     cc
157                    vev(indev,1) = vev(indev,1)
158          1                 + rl * zev(indev,2)
159          2                  / snnp1ev(indev)
160     cc
161                    vev(indev,2) = vev(indev,2)
162          1                 - rl * zev(indev,1)
163          2                  / snnp1ev(indev)
164     cc
165                 enddo
166              endif
167     cc
168           enddo
169     cc
170     cc......................................................................
171     cc
172           do locl=1,ls_max_node
173                   l=ls_node(locl,1)
174              jbasev=ls_node(locl,2)
175              jbasod=ls_node(locl,3)
176              indev1 = indlsev(L,L) + 1
177              if (mod(L,2).eq.mod(jcap+1,2)) then
178                 indev2 = indlsev(jcap-1,L)
179              else
180                 indev2 = indlsev(jcap  ,L)
181              endif
182              indod1 = indlsod(l+1,l)
183              inddif = indev1 - indod1
184     cc
185              do indev = indev1 , indev2
186     cc
187                      uod(indev-inddif,1) = uod(indev-inddif,1)
188          1      + epsedn(indev)          * zev(indev       ,1)
189     cc
190                      uod(indev-inddif,2) = uod(indev-inddif,2)
191          1      + epsedn(indev)          * zev(indev       ,2)
192     cc
193              enddo
194     cc
195           enddo
196     cc
197     cc......................................................................
198     cc
199           do locl=1,ls_max_node
200                   l=ls_node(locl,1)
201              jbasev=ls_node(locl,2)
202              jbasod=ls_node(locl,3)
203              indev1 = indlsev(L,L)
204              if (mod(L,2).eq.mod(jcap+1,2)) then
205                 indev2 = indlsev(jcap+1,L) - 1
206              else
207                 indev2 = indlsev(jcap  ,L) - 1
208              endif
209              indod1 = indlsod(l+1,l)
210              inddif = indev1 - indod1
211     cc
212              do indev = indev1 , indev2
213     cc
214                      vev(indev,1)      = vev(indev       ,1)
215          1      - epsodn(indev-inddif) * dod(indev-inddif,1)
216     cc
217                      vev(indev,2)      = vev(indev       ,2)
218          1      - epsodn(indev-inddif) * dod(indev-inddif,2)
219     cc
220              enddo
221     cc
222           enddo
223     cc
224     cc......................................................................
225     cc
226     cc
227           do locl=1,ls_max_node
228                   l=ls_node(locl,1)
229              jbasev=ls_node(locl,2)
230              jbasod=ls_node(locl,3)
231              indev1 = indlsev(L,L)
232              indod1 = indlsod(L+1,L)
233              if (mod(L,2).eq.mod(jcap+1,2)) then
234                 indev2 = indlsev(jcap+1,L)
235                 indod2 = indlsod(jcap  ,L)
236              else
237                 indev2 = indlsev(jcap  ,L)
238                 indod2 = indlsod(jcap+1,L)
239              endif
240              do indod = indod1 , indod2
241     cc
242                 uod(indod,1) = uod(indod,1) * rerth
243                 uod(indod,2) = uod(indod,2) * rerth
244     cc
245              enddo
246     cc
247              do indev = indev1 , indev2
248     cc
249                 vev(indev,1) = vev(indev,1) * rerth
250                 vev(indev,2) = vev(indev,2) * rerth
251     cc
252              enddo
253     cc
254           enddo
255     cc
256           return
257           end
258