FV3 Bundle
fv_restart_tlm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20 module fv_restart_tlm_mod
21 
22 implicit none
23 private
24 
25 public :: d2c_setup, d2a_setup
26 public :: d2c_setup_tlm
27 
28 CONTAINS
29 ! Differentiation of d2c_setup in forward (tangent) mode:
30 ! variations of useful results: uc vc
31 ! with respect to varying inputs: u v uc vc
32  SUBROUTINE d2c_setup_tlm(u, u_tl, v, v_tl, ua, va, uc, uc_tl, vc, &
33 & vc_tl, dord4, isd, ied, jsd, jed, is, ie, js, je, npx, npy, &
34 & grid_type, nested, se_corner, sw_corner, ne_corner, nw_corner, &
35 & rsin_u, rsin_v, cosa_s, rsin2)
36  IMPLICIT NONE
37  LOGICAL, INTENT(IN) :: dord4
38  INTEGER, INTENT(IN) :: isd, ied, jsd, jed, is, ie, js, je, npx, npy&
39 & , grid_type
40  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
41  REAL, INTENT(IN) :: u_tl(isd:ied, jsd:jed+1)
42  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
43  REAL, INTENT(IN) :: v_tl(isd:ied+1, jsd:jed)
44  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: ua
45  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: va
46  REAL, DIMENSION(isd:ied+1, jsd:jed), INTENT(OUT) :: uc
47  REAL, DIMENSION(isd:ied+1, jsd:jed), INTENT(OUT) :: uc_tl
48  REAL, DIMENSION(isd:ied, jsd:jed+1), INTENT(OUT) :: vc
49  REAL, DIMENSION(isd:ied, jsd:jed+1), INTENT(OUT) :: vc_tl
50  LOGICAL, INTENT(IN) :: nested, se_corner, sw_corner, ne_corner, &
51 & nw_corner
52  REAL, INTENT(IN) :: rsin_u(isd:ied+1, jsd:jed)
53  REAL, INTENT(IN) :: rsin_v(isd:ied, jsd:jed+1)
54  REAL, INTENT(IN) :: cosa_s(isd:ied, jsd:jed)
55  REAL, INTENT(IN) :: rsin2(isd:ied, jsd:jed)
56 ! Local
57  REAL, DIMENSION(isd:ied, jsd:jed) :: utmp, vtmp
58  REAL, DIMENSION(isd:ied, jsd:jed) :: utmp_tl, vtmp_tl
59  REAL, PARAMETER :: t11=27./28., t12=-(13./28.), t13=3./7., t14=6./7.&
60 & , t15=3./28.
61  REAL, PARAMETER :: a1=0.5625
62  REAL, PARAMETER :: a2=-0.0625
63  REAL, PARAMETER :: c1=-(2./14.)
64  REAL, PARAMETER :: c2=11./14.
65  REAL, PARAMETER :: c3=5./14.
66  INTEGER :: npt, i, j, ifirst, ilast, id
67  INTRINSIC max
68  INTRINSIC min
69  INTEGER :: max1
70  INTEGER :: max2
71  INTEGER :: max3
72  INTEGER :: max4
73  INTEGER :: max5
74  INTEGER :: max6
75  INTEGER :: min1
76  INTEGER :: min2
77  INTEGER :: min3
78  INTEGER :: min4
79  INTEGER :: min5
80  INTEGER :: min6
81  IF (dord4) THEN
82  id = 1
83  ELSE
84  id = 0
85  END IF
86  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
87  npt = 4
88  ELSE
89  npt = -2
90  END IF
91  IF (nested) THEN
92  utmp_tl = 0.0
93  DO j=jsd+1,jed-1
94  DO i=isd,ied
95  utmp_tl(i, j) = a2*(u_tl(i, j-1)+u_tl(i, j+2)) + a1*(u_tl(i, j&
96 & )+u_tl(i, j+1))
97  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
98  END DO
99  END DO
100  DO i=isd,ied
101 !j = jsd
102  utmp_tl(i, jsd) = 0.5*(u_tl(i, jsd)+u_tl(i, jsd+1))
103  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
104 !j = jed
105  utmp_tl(i, jed) = 0.5*(u_tl(i, jed)+u_tl(i, jed+1))
106  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
107  END DO
108  vtmp_tl = 0.0
109  DO j=jsd,jed
110  DO i=isd+1,ied-1
111  vtmp_tl(i, j) = a2*(v_tl(i-1, j)+v_tl(i+2, j)) + a1*(v_tl(i, j&
112 & )+v_tl(i+1, j))
113  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
114  END DO
115 !i = isd
116  vtmp_tl(isd, j) = 0.5*(v_tl(isd, j)+v_tl(isd+1, j))
117  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
118 !i = ied
119  vtmp_tl(ied, j) = 0.5*(v_tl(ied, j)+v_tl(ied+1, j))
120  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
121  END DO
122  DO j=jsd,jed
123  DO i=isd,ied
124  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
125  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
126  END DO
127  END DO
128  ELSE
129 !----------
130 ! Interior:
131 !----------
132  utmp = 0.
133  vtmp = 0.
134  IF (npt .LT. js - 1) THEN
135  max1 = js - 1
136  ELSE
137  max1 = npt
138  END IF
139  IF (npy - npt .GT. je + 1) THEN
140  min1 = je + 1
141  utmp_tl = 0.0
142  ELSE
143  min1 = npy - npt
144  utmp_tl = 0.0
145  END IF
146  DO j=max1,min1
147  IF (npt .LT. isd) THEN
148  max2 = isd
149  ELSE
150  max2 = npt
151  END IF
152  IF (npx - npt .GT. ied) THEN
153  min2 = ied
154  ELSE
155  min2 = npx - npt
156  END IF
157  DO i=max2,min2
158  utmp_tl(i, j) = a2*(u_tl(i, j-1)+u_tl(i, j+2)) + a1*(u_tl(i, j&
159 & )+u_tl(i, j+1))
160  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
161  END DO
162  END DO
163  IF (npt .LT. jsd) THEN
164  max3 = jsd
165  ELSE
166  max3 = npt
167  END IF
168  IF (npy - npt .GT. jed) THEN
169  min3 = jed
170  vtmp_tl = 0.0
171  ELSE
172  min3 = npy - npt
173  vtmp_tl = 0.0
174  END IF
175  DO j=max3,min3
176  IF (npt .LT. is - 1) THEN
177  max4 = is - 1
178  ELSE
179  max4 = npt
180  END IF
181  IF (npx - npt .GT. ie + 1) THEN
182  min4 = ie + 1
183  ELSE
184  min4 = npx - npt
185  END IF
186  DO i=max4,min4
187  vtmp_tl(i, j) = a2*(v_tl(i-1, j)+v_tl(i+2, j)) + a1*(v_tl(i, j&
188 & )+v_tl(i+1, j))
189  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
190  END DO
191  END DO
192 !----------
193 ! edges:
194 !----------
195  IF (grid_type .LT. 3) THEN
196  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
197  DO j=jsd,npt-1
198  DO i=isd,ied
199  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
200  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
201  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
202  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
203  END DO
204  END DO
205  END IF
206  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
207  DO j=npy-npt+1,jed
208  DO i=isd,ied
209  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
210  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
211  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
212  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
213  END DO
214  END DO
215  END IF
216  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
217  IF (npt .LT. jsd) THEN
218  max5 = jsd
219  ELSE
220  max5 = npt
221  END IF
222  IF (npy - npt .GT. jed) THEN
223  min5 = jed
224  ELSE
225  min5 = npy - npt
226  END IF
227  DO j=max5,min5
228  DO i=isd,npt-1
229  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
230  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
231  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
232  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
233  END DO
234  END DO
235  END IF
236  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
237  IF (npt .LT. jsd) THEN
238  max6 = jsd
239  ELSE
240  max6 = npt
241  END IF
242  IF (npy - npt .GT. jed) THEN
243  min6 = jed
244  ELSE
245  min6 = npy - npt
246  END IF
247  DO j=max6,min6
248  DO i=npx-npt+1,ied
249  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
250  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
251  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
252  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
253  END DO
254  END DO
255  END IF
256  END IF
257  DO j=js-1-id,je+1+id
258  DO i=is-1-id,ie+1+id
259  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
260  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
261  END DO
262  END DO
263  END IF
264 ! A -> C
265 !--------------
266 ! Fix the edges
267 !--------------
268 ! Xdir:
269  IF (sw_corner) THEN
270  DO i=-2,0
271  utmp_tl(i, 0) = -vtmp_tl(0, 1-i)
272  utmp(i, 0) = -vtmp(0, 1-i)
273  END DO
274  END IF
275  IF (se_corner) THEN
276  DO i=0,2
277  utmp_tl(npx+i, 0) = vtmp_tl(npx, i+1)
278  utmp(npx+i, 0) = vtmp(npx, i+1)
279  END DO
280  END IF
281  IF (ne_corner) THEN
282  DO i=0,2
283  utmp_tl(npx+i, npy) = -vtmp_tl(npx, je-i)
284  utmp(npx+i, npy) = -vtmp(npx, je-i)
285  END DO
286  END IF
287  IF (nw_corner) THEN
288  DO i=-2,0
289  utmp_tl(i, npy) = vtmp_tl(0, je+i)
290  utmp(i, npy) = vtmp(0, je+i)
291  END DO
292  END IF
293  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
294  IF (3 .LT. is - 1) THEN
295  ifirst = is - 1
296  ELSE
297  ifirst = 3
298  END IF
299  IF (npx - 2 .GT. ie + 2) THEN
300  ilast = ie + 2
301  ELSE
302  ilast = npx - 2
303  END IF
304  ELSE
305  ifirst = is - 1
306  ilast = ie + 2
307  END IF
308 !---------------------------------------------
309 ! 4th order interpolation for interior points:
310 !---------------------------------------------
311  DO j=js-1,je+1
312  DO i=ifirst,ilast
313  uc_tl(i, j) = a1*(utmp_tl(i-1, j)+utmp_tl(i, j)) + a2*(utmp_tl(i&
314 & -2, j)+utmp_tl(i+1, j))
315  uc(i, j) = a1*(utmp(i-1, j)+utmp(i, j)) + a2*(utmp(i-2, j)+utmp(&
316 & i+1, j))
317  END DO
318  END DO
319  IF (grid_type .LT. 3) THEN
320 ! Xdir:
321  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
322  DO j=js-1,je+1
323  uc_tl(0, j) = c1*utmp_tl(-2, j) + c2*utmp_tl(-1, j) + c3*&
324 & utmp_tl(0, j)
325  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
326  uc_tl(1, j) = rsin_u(1, j)*(t14*(utmp_tl(0, j)+utmp_tl(1, j))+&
327 & t12*(utmp_tl(-1, j)+utmp_tl(2, j))+t15*(utmp_tl(-2, j)+&
328 & utmp_tl(3, j)))
329  uc(1, j) = (t14*(utmp(0, j)+utmp(1, j))+t12*(utmp(-1, j)+utmp(&
330 & 2, j))+t15*(utmp(-2, j)+utmp(3, j)))*rsin_u(1, j)
331  uc_tl(2, j) = c1*utmp_tl(3, j) + c2*utmp_tl(2, j) + c3*utmp_tl&
332 & (1, j)
333  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
334  END DO
335  END IF
336  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
337  DO j=js-1,je+1
338  uc_tl(npx-1, j) = c1*utmp_tl(npx-3, j) + c2*utmp_tl(npx-2, j) &
339 & + c3*utmp_tl(npx-1, j)
340  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
341 & (npx-1, j)
342  uc_tl(npx, j) = rsin_u(npx, j)*(t14*(utmp_tl(npx-1, j)+utmp_tl&
343 & (npx, j))+t12*(utmp_tl(npx-2, j)+utmp_tl(npx+1, j))+t15*(&
344 & utmp_tl(npx-3, j)+utmp_tl(npx+2, j)))
345  uc(npx, j) = (t14*(utmp(npx-1, j)+utmp(npx, j))+t12*(utmp(npx-&
346 & 2, j)+utmp(npx+1, j))+t15*(utmp(npx-3, j)+utmp(npx+2, j)))*&
347 & rsin_u(npx, j)
348  uc_tl(npx+1, j) = c3*utmp_tl(npx, j) + c2*utmp_tl(npx+1, j) + &
349 & c1*utmp_tl(npx+2, j)
350  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
351 & npx+2, j)
352  END DO
353  END IF
354  END IF
355 !------
356 ! Ydir:
357 !------
358  IF (sw_corner) THEN
359  DO j=-2,0
360  vtmp_tl(0, j) = -utmp_tl(1-j, 0)
361  vtmp(0, j) = -utmp(1-j, 0)
362  END DO
363  END IF
364  IF (nw_corner) THEN
365  DO j=0,2
366  vtmp_tl(0, npy+j) = utmp_tl(j+1, npy)
367  vtmp(0, npy+j) = utmp(j+1, npy)
368  END DO
369  END IF
370  IF (se_corner) THEN
371  DO j=-2,0
372  vtmp_tl(npx, j) = utmp_tl(ie+j, 0)
373  vtmp(npx, j) = utmp(ie+j, 0)
374  END DO
375  END IF
376  IF (ne_corner) THEN
377  DO j=0,2
378  vtmp_tl(npx, npy+j) = -utmp_tl(ie-j, npy)
379  vtmp(npx, npy+j) = -utmp(ie-j, npy)
380  END DO
381  END IF
382  IF (grid_type .LT. 3) THEN
383  DO j=js-1,je+2
384  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
385  DO i=is-1,ie+1
386  vc_tl(i, 1) = rsin_v(i, 1)*(t14*(vtmp_tl(i, 0)+vtmp_tl(i, 1)&
387 & )+t12*(vtmp_tl(i, -1)+vtmp_tl(i, 2))+t15*(vtmp_tl(i, -2)+&
388 & vtmp_tl(i, 3)))
389  vc(i, 1) = (t14*(vtmp(i, 0)+vtmp(i, 1))+t12*(vtmp(i, -1)+&
390 & vtmp(i, 2))+t15*(vtmp(i, -2)+vtmp(i, 3)))*rsin_v(i, 1)
391  END DO
392  ELSE IF ((j .EQ. 0 .OR. j .EQ. npy - 1) .AND. (.NOT.nested)) &
393 & THEN
394  DO i=is-1,ie+1
395  vc_tl(i, j) = c1*vtmp_tl(i, j-2) + c2*vtmp_tl(i, j-1) + c3*&
396 & vtmp_tl(i, j)
397  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
398  END DO
399  ELSE IF ((j .EQ. 2 .OR. j .EQ. npy + 1) .AND. (.NOT.nested)) &
400 & THEN
401  DO i=is-1,ie+1
402  vc_tl(i, j) = c1*vtmp_tl(i, j+1) + c2*vtmp_tl(i, j) + c3*&
403 & vtmp_tl(i, j-1)
404  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
405  END DO
406  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
407  DO i=is-1,ie+1
408  vc_tl(i, npy) = rsin_v(i, npy)*(t14*(vtmp_tl(i, npy-1)+&
409 & vtmp_tl(i, npy))+t12*(vtmp_tl(i, npy-2)+vtmp_tl(i, npy+1))&
410 & +t15*(vtmp_tl(i, npy-3)+vtmp_tl(i, npy+2)))
411  vc(i, npy) = (t14*(vtmp(i, npy-1)+vtmp(i, npy))+t12*(vtmp(i&
412 & , npy-2)+vtmp(i, npy+1))+t15*(vtmp(i, npy-3)+vtmp(i, npy+2&
413 & )))*rsin_v(i, npy)
414  END DO
415  ELSE
416 ! 4th order interpolation for interior points:
417  DO i=is-1,ie+1
418  vc_tl(i, j) = a2*(vtmp_tl(i, j-2)+vtmp_tl(i, j+1)) + a1*(&
419 & vtmp_tl(i, j-1)+vtmp_tl(i, j))
420  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
421 & +vtmp(i, j))
422  END DO
423  END IF
424  END DO
425  ELSE
426 ! 4th order interpolation:
427  DO j=js-1,je+2
428  DO i=is-1,ie+1
429  vc_tl(i, j) = a2*(vtmp_tl(i, j-2)+vtmp_tl(i, j+1)) + a1*(&
430 & vtmp_tl(i, j-1)+vtmp_tl(i, j))
431  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
432 & vtmp(i, j))
433  END DO
434  END DO
435  END IF
436  END SUBROUTINE d2c_setup_tlm
437  SUBROUTINE d2c_setup(u, v, ua, va, uc, vc, dord4, isd, ied, jsd, jed, &
438 & is, ie, js, je, npx, npy, grid_type, nested, se_corner, sw_corner, &
439 & ne_corner, nw_corner, rsin_u, rsin_v, cosa_s, rsin2)
440  IMPLICIT NONE
441  LOGICAL, INTENT(IN) :: dord4
442  INTEGER, INTENT(IN) :: isd, ied, jsd, jed, is, ie, js, je, npx, npy&
443 & , grid_type
444  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
445  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
446  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: ua
447  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: va
448  REAL, DIMENSION(isd:ied+1, jsd:jed), INTENT(OUT) :: uc
449  REAL, DIMENSION(isd:ied, jsd:jed+1), INTENT(OUT) :: vc
450  LOGICAL, INTENT(IN) :: nested, se_corner, sw_corner, ne_corner, &
451 & nw_corner
452  REAL, INTENT(IN) :: rsin_u(isd:ied+1, jsd:jed)
453  REAL, INTENT(IN) :: rsin_v(isd:ied, jsd:jed+1)
454  REAL, INTENT(IN) :: cosa_s(isd:ied, jsd:jed)
455  REAL, INTENT(IN) :: rsin2(isd:ied, jsd:jed)
456 ! Local
457  REAL, DIMENSION(isd:ied, jsd:jed) :: utmp, vtmp
458  REAL, PARAMETER :: t11=27./28., t12=-(13./28.), t13=3./7., t14=6./7.&
459 & , t15=3./28.
460  REAL, PARAMETER :: a1=0.5625
461  REAL, PARAMETER :: a2=-0.0625
462  REAL, PARAMETER :: c1=-(2./14.)
463  REAL, PARAMETER :: c2=11./14.
464  REAL, PARAMETER :: c3=5./14.
465  INTEGER :: npt, i, j, ifirst, ilast, id
466  INTRINSIC max
467  INTRINSIC min
468  INTEGER :: max1
469  INTEGER :: max2
470  INTEGER :: max3
471  INTEGER :: max4
472  INTEGER :: max5
473  INTEGER :: max6
474  INTEGER :: min1
475  INTEGER :: min2
476  INTEGER :: min3
477  INTEGER :: min4
478  INTEGER :: min5
479  INTEGER :: min6
480  IF (dord4) THEN
481  id = 1
482  ELSE
483  id = 0
484  END IF
485  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
486  npt = 4
487  ELSE
488  npt = -2
489  END IF
490  IF (nested) THEN
491  DO j=jsd+1,jed-1
492  DO i=isd,ied
493  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
494  END DO
495  END DO
496  DO i=isd,ied
497 !j = jsd
498  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
499 !j = jed
500  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
501  END DO
502  DO j=jsd,jed
503  DO i=isd+1,ied-1
504  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
505  END DO
506 !i = isd
507  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
508 !i = ied
509  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
510  END DO
511  DO j=jsd,jed
512  DO i=isd,ied
513  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
514  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
515  END DO
516  END DO
517  ELSE
518 !----------
519 ! Interior:
520 !----------
521  utmp = 0.
522  vtmp = 0.
523  IF (npt .LT. js - 1) THEN
524  max1 = js - 1
525  ELSE
526  max1 = npt
527  END IF
528  IF (npy - npt .GT. je + 1) THEN
529  min1 = je + 1
530  ELSE
531  min1 = npy - npt
532  END IF
533  DO j=max1,min1
534  IF (npt .LT. isd) THEN
535  max2 = isd
536  ELSE
537  max2 = npt
538  END IF
539  IF (npx - npt .GT. ied) THEN
540  min2 = ied
541  ELSE
542  min2 = npx - npt
543  END IF
544  DO i=max2,min2
545  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
546  END DO
547  END DO
548  IF (npt .LT. jsd) THEN
549  max3 = jsd
550  ELSE
551  max3 = npt
552  END IF
553  IF (npy - npt .GT. jed) THEN
554  min3 = jed
555  ELSE
556  min3 = npy - npt
557  END IF
558  DO j=max3,min3
559  IF (npt .LT. is - 1) THEN
560  max4 = is - 1
561  ELSE
562  max4 = npt
563  END IF
564  IF (npx - npt .GT. ie + 1) THEN
565  min4 = ie + 1
566  ELSE
567  min4 = npx - npt
568  END IF
569  DO i=max4,min4
570  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
571  END DO
572  END DO
573 !----------
574 ! edges:
575 !----------
576  IF (grid_type .LT. 3) THEN
577  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
578  DO j=jsd,npt-1
579  DO i=isd,ied
580  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
581  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
582  END DO
583  END DO
584  END IF
585  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
586  DO j=npy-npt+1,jed
587  DO i=isd,ied
588  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
589  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
590  END DO
591  END DO
592  END IF
593  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
594  IF (npt .LT. jsd) THEN
595  max5 = jsd
596  ELSE
597  max5 = npt
598  END IF
599  IF (npy - npt .GT. jed) THEN
600  min5 = jed
601  ELSE
602  min5 = npy - npt
603  END IF
604  DO j=max5,min5
605  DO i=isd,npt-1
606  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
607  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
608  END DO
609  END DO
610  END IF
611  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
612  IF (npt .LT. jsd) THEN
613  max6 = jsd
614  ELSE
615  max6 = npt
616  END IF
617  IF (npy - npt .GT. jed) THEN
618  min6 = jed
619  ELSE
620  min6 = npy - npt
621  END IF
622  DO j=max6,min6
623  DO i=npx-npt+1,ied
624  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
625  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
626  END DO
627  END DO
628  END IF
629  END IF
630  DO j=js-1-id,je+1+id
631  DO i=is-1-id,ie+1+id
632  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
633  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
634  END DO
635  END DO
636  END IF
637 ! A -> C
638 !--------------
639 ! Fix the edges
640 !--------------
641 ! Xdir:
642  IF (sw_corner) THEN
643  DO i=-2,0
644  utmp(i, 0) = -vtmp(0, 1-i)
645  END DO
646  END IF
647  IF (se_corner) THEN
648  DO i=0,2
649  utmp(npx+i, 0) = vtmp(npx, i+1)
650  END DO
651  END IF
652  IF (ne_corner) THEN
653  DO i=0,2
654  utmp(npx+i, npy) = -vtmp(npx, je-i)
655  END DO
656  END IF
657  IF (nw_corner) THEN
658  DO i=-2,0
659  utmp(i, npy) = vtmp(0, je+i)
660  END DO
661  END IF
662  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
663  IF (3 .LT. is - 1) THEN
664  ifirst = is - 1
665  ELSE
666  ifirst = 3
667  END IF
668  IF (npx - 2 .GT. ie + 2) THEN
669  ilast = ie + 2
670  ELSE
671  ilast = npx - 2
672  END IF
673  ELSE
674  ifirst = is - 1
675  ilast = ie + 2
676  END IF
677 !---------------------------------------------
678 ! 4th order interpolation for interior points:
679 !---------------------------------------------
680  DO j=js-1,je+1
681  DO i=ifirst,ilast
682  uc(i, j) = a1*(utmp(i-1, j)+utmp(i, j)) + a2*(utmp(i-2, j)+utmp(&
683 & i+1, j))
684  END DO
685  END DO
686  IF (grid_type .LT. 3) THEN
687 ! Xdir:
688  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
689  DO j=js-1,je+1
690  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
691  uc(1, j) = (t14*(utmp(0, j)+utmp(1, j))+t12*(utmp(-1, j)+utmp(&
692 & 2, j))+t15*(utmp(-2, j)+utmp(3, j)))*rsin_u(1, j)
693  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
694  END DO
695  END IF
696  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
697  DO j=js-1,je+1
698  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
699 & (npx-1, j)
700  uc(npx, j) = (t14*(utmp(npx-1, j)+utmp(npx, j))+t12*(utmp(npx-&
701 & 2, j)+utmp(npx+1, j))+t15*(utmp(npx-3, j)+utmp(npx+2, j)))*&
702 & rsin_u(npx, j)
703  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
704 & npx+2, j)
705  END DO
706  END IF
707  END IF
708 !------
709 ! Ydir:
710 !------
711  IF (sw_corner) THEN
712  DO j=-2,0
713  vtmp(0, j) = -utmp(1-j, 0)
714  END DO
715  END IF
716  IF (nw_corner) THEN
717  DO j=0,2
718  vtmp(0, npy+j) = utmp(j+1, npy)
719  END DO
720  END IF
721  IF (se_corner) THEN
722  DO j=-2,0
723  vtmp(npx, j) = utmp(ie+j, 0)
724  END DO
725  END IF
726  IF (ne_corner) THEN
727  DO j=0,2
728  vtmp(npx, npy+j) = -utmp(ie-j, npy)
729  END DO
730  END IF
731  IF (grid_type .LT. 3) THEN
732  DO j=js-1,je+2
733  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
734  DO i=is-1,ie+1
735  vc(i, 1) = (t14*(vtmp(i, 0)+vtmp(i, 1))+t12*(vtmp(i, -1)+&
736 & vtmp(i, 2))+t15*(vtmp(i, -2)+vtmp(i, 3)))*rsin_v(i, 1)
737  END DO
738  ELSE IF ((j .EQ. 0 .OR. j .EQ. npy - 1) .AND. (.NOT.nested)) &
739 & THEN
740  DO i=is-1,ie+1
741  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
742  END DO
743  ELSE IF ((j .EQ. 2 .OR. j .EQ. npy + 1) .AND. (.NOT.nested)) &
744 & THEN
745  DO i=is-1,ie+1
746  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
747  END DO
748  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
749  DO i=is-1,ie+1
750  vc(i, npy) = (t14*(vtmp(i, npy-1)+vtmp(i, npy))+t12*(vtmp(i&
751 & , npy-2)+vtmp(i, npy+1))+t15*(vtmp(i, npy-3)+vtmp(i, npy+2&
752 & )))*rsin_v(i, npy)
753  END DO
754  ELSE
755 ! 4th order interpolation for interior points:
756  DO i=is-1,ie+1
757  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
758 & +vtmp(i, j))
759  END DO
760  END IF
761  END DO
762  ELSE
763 ! 4th order interpolation:
764  DO j=js-1,je+2
765  DO i=is-1,ie+1
766  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
767 & vtmp(i, j))
768  END DO
769  END DO
770  END IF
771  END SUBROUTINE d2c_setup
772  SUBROUTINE d2a_setup(u, v, ua, va, dord4, isd, ied, jsd, jed, is, ie, &
773 & js, je, npx, npy, grid_type, nested, cosa_s, rsin2)
774  IMPLICIT NONE
775  LOGICAL, INTENT(IN) :: dord4
776  INTEGER, INTENT(IN) :: isd, ied, jsd, jed, is, ie, js, je, npx, npy&
777 & , grid_type
778  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
779  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
780  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: ua
781  REAL, DIMENSION(isd:ied, jsd:jed), INTENT(OUT) :: va
782  REAL, INTENT(IN) :: cosa_s(isd:ied, jsd:jed)
783  REAL, INTENT(IN) :: rsin2(isd:ied, jsd:jed)
784  LOGICAL, INTENT(IN) :: nested
785 ! Local
786  REAL, DIMENSION(isd:ied, jsd:jed) :: utmp, vtmp
787  REAL, PARAMETER :: t11=27./28., t12=-(13./28.), t13=3./7., t14=6./7.&
788 & , t15=3./28.
789  REAL, PARAMETER :: a1=0.5625
790  REAL, PARAMETER :: a2=-0.0625
791  REAL, PARAMETER :: c1=-(2./14.)
792  REAL, PARAMETER :: c2=11./14.
793  REAL, PARAMETER :: c3=5./14.
794  INTEGER :: npt, i, j, ifirst, ilast, id
795  INTRINSIC max
796  INTRINSIC min
797  INTEGER :: max1
798  INTEGER :: max2
799  INTEGER :: max3
800  INTEGER :: max4
801  INTEGER :: max5
802  INTEGER :: max6
803  INTEGER :: min1
804  INTEGER :: min2
805  INTEGER :: min3
806  INTEGER :: min4
807  INTEGER :: min5
808  INTEGER :: min6
809  IF (dord4) THEN
810  id = 1
811  ELSE
812  id = 0
813  END IF
814  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
815  npt = 4
816  ELSE
817  npt = -2
818  END IF
819  IF (nested) THEN
820  DO j=jsd+1,jed-1
821  DO i=isd,ied
822  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
823  END DO
824  END DO
825  DO i=isd,ied
826 !j = jsd
827  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
828 !j = jed
829  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
830  END DO
831  DO j=jsd,jed
832  DO i=isd+1,ied-1
833  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
834  END DO
835 !i = isd
836  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
837 !i = ied
838  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
839  END DO
840  ELSE
841  IF (npt .LT. js - 1) THEN
842  max1 = js - 1
843  ELSE
844  max1 = npt
845  END IF
846  IF (npy - npt .GT. je + 1) THEN
847  min1 = je + 1
848  ELSE
849  min1 = npy - npt
850  END IF
851 !----------
852 ! Interior:
853 !----------
854  DO j=max1,min1
855  IF (npt .LT. isd) THEN
856  max2 = isd
857  ELSE
858  max2 = npt
859  END IF
860  IF (npx - npt .GT. ied) THEN
861  min2 = ied
862  ELSE
863  min2 = npx - npt
864  END IF
865  DO i=max2,min2
866  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
867  END DO
868  END DO
869  IF (npt .LT. jsd) THEN
870  max3 = jsd
871  ELSE
872  max3 = npt
873  END IF
874  IF (npy - npt .GT. jed) THEN
875  min3 = jed
876  ELSE
877  min3 = npy - npt
878  END IF
879  DO j=max3,min3
880  IF (npt .LT. is - 1) THEN
881  max4 = is - 1
882  ELSE
883  max4 = npt
884  END IF
885  IF (npx - npt .GT. ie + 1) THEN
886  min4 = ie + 1
887  ELSE
888  min4 = npx - npt
889  END IF
890  DO i=max4,min4
891  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
892  END DO
893  END DO
894 !----------
895 ! edges:
896 !----------
897  IF (grid_type .LT. 3) THEN
898  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
899  DO j=jsd,npt-1
900  DO i=isd,ied
901  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
902  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
903  END DO
904  END DO
905  END IF
906  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
907  DO j=npy-npt+1,jed
908  DO i=isd,ied
909  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
910  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
911  END DO
912  END DO
913  END IF
914  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
915  IF (npt .LT. jsd) THEN
916  max5 = jsd
917  ELSE
918  max5 = npt
919  END IF
920  IF (npy - npt .GT. jed) THEN
921  min5 = jed
922  ELSE
923  min5 = npy - npt
924  END IF
925  DO j=max5,min5
926  DO i=isd,npt-1
927  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
928  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
929  END DO
930  END DO
931  END IF
932  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
933  IF (npt .LT. jsd) THEN
934  max6 = jsd
935  ELSE
936  max6 = npt
937  END IF
938  IF (npy - npt .GT. jed) THEN
939  min6 = jed
940  ELSE
941  min6 = npy - npt
942  END IF
943  DO j=max6,min6
944  DO i=npx-npt+1,ied
945  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
946  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
947  END DO
948  END DO
949  END IF
950  END IF
951  END IF
952  DO j=js-1-id,je+1+id
953  DO i=is-1-id,ie+1+id
954  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
955  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
956  END DO
957  END DO
958  END SUBROUTINE d2a_setup
959 
960 end module fv_restart_tlm_mod
fv_restart_tlm_mod::d2c_setup
subroutine, public d2c_setup(u, v, ua, va, uc, vc, dord4, isd, ied, jsd, jed, is, ie, js, je, npx, npy, grid_type, nested, se_corner, sw_corner, ne_corner, nw_corner, rsin_u, rsin_v, cosa_s, rsin2)
Definition: fv_restart_tlm.F90:440
fv_restart_tlm_mod::d2a_setup
subroutine, public d2a_setup(u, v, ua, va, dord4, isd, ied, jsd, jed, is, ie, js, je, npx, npy, grid_type, nested, cosa_s, rsin2)
Definition: fv_restart_tlm.F90:774
fv_restart_tlm_mod::d2c_setup_tlm
subroutine, public d2c_setup_tlm(u, u_tl, v, v_tl, ua, va, uc, uc_tl, vc, vc_tl, dord4, isd, ied, jsd, jed, is, ie, js, je, npx, npy, grid_type, nested, se_corner, sw_corner, ne_corner, nw_corner, rsin_u, rsin_v, cosa_s, rsin2)
Definition: fv_restart_tlm.F90:36
max
#define max(a, b)
Definition: mosaic_util.h:33
fv_restart_tlm_mod
Definition: fv_restart_tlm.F90:20
min
#define min(a, b)
Definition: mosaic_util.h:32
unstructured_grid_mod::grid_type
Derived type containing the data.
Definition: unstructured_grid_mod.F90:23