source: palm/trunk/SOURCE/tridia_solver_mod.f90 @ 4380

Last change on this file since 4380 was 4360, checked in by suehring, 5 years ago

Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update

  • Property svn:keywords set to Id
File size: 21.1 KB
Line 
1!> @file tridia_solver_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2020 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: tridia_solver_mod.f90 4360 2020-01-07 11:25:50Z monakurppa $
27! Added missing OpenMP directives
28!
29! 4182 2019-08-22 15:20:23Z scharf
30! Corrected "Former revisions" section
31!
32! 3761 2019-02-25 15:31:42Z raasch
33! OpenACC modification to prevent compiler warning about unused variable
34!
35! 3690 2019-01-22 22:56:42Z knoop
36! OpenACC port for SPEC
37!
38! 1212 2013-08-15 08:46:27Z raasch
39! Initial revision.
40! Routines have been moved to seperate module from former file poisfft to here.
41! The tridiagonal matrix coefficients of array tri are calculated only once at
42! the beginning, i.e. routine split is called within tridia_init.
43!
44!
45! Description:
46! ------------
47!> solves the linear system of equations:
48!>
49!> -(4 pi^2(i^2/(dx^2*nnx^2)+j^2/(dy^2*nny^2))+
50!>   1/(dzu(k)*dzw(k))+1/(dzu(k-1)*dzw(k)))*p(i,j,k)+
51!> 1/(dzu(k)*dzw(k))*p(i,j,k+1)+1/(dzu(k-1)*dzw(k))*p(i,j,k-1)=d(i,j,k)
52!>
53!> by using the Thomas algorithm
54!------------------------------------------------------------------------------!
55
56#define __acc_fft_device ( defined( _OPENACC ) && ( defined ( __cuda_fft ) ) )
57
58 MODULE tridia_solver
59 
60
61    USE basic_constants_and_equations_mod,                                     &
62        ONLY:  pi
63
64    USE indices,                                                               &
65        ONLY:  nx, ny, nz
66
67    USE kinds
68
69    USE transpose_indices,                                                     &
70        ONLY:  nxl_z, nyn_z, nxr_z, nys_z
71
72    IMPLICIT NONE
73
74    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ddzuw !<
75
76    PRIVATE
77
78    INTERFACE tridia_substi
79       MODULE PROCEDURE tridia_substi
80    END INTERFACE tridia_substi
81
82    INTERFACE tridia_substi_overlap
83       MODULE PROCEDURE tridia_substi_overlap
84    END INTERFACE tridia_substi_overlap
85
86    PUBLIC  tridia_substi, tridia_substi_overlap, tridia_init, tridia_1dd
87
88 CONTAINS
89
90
91!------------------------------------------------------------------------------!
92! Description:
93! ------------
94!> @todo Missing subroutine description.
95!------------------------------------------------------------------------------!
96    SUBROUTINE tridia_init
97
98       USE arrays_3d,                                                          &
99           ONLY:  ddzu_pres, ddzw, rho_air_zw
100
101#if defined( _OPENACC )
102       USE arrays_3d,                                                          &
103           ONLY:  tri
104#endif
105
106       IMPLICIT NONE
107
108       INTEGER(iwp) ::  k !<
109
110       ALLOCATE( ddzuw(0:nz-1,3) )
111
112       DO  k = 0, nz-1
113          ddzuw(k,1) = ddzu_pres(k+1) * ddzw(k+1) * rho_air_zw(k)
114          ddzuw(k,2) = ddzu_pres(k+2) * ddzw(k+1) * rho_air_zw(k+1)
115          ddzuw(k,3) = -1.0_wp * &
116                       ( ddzu_pres(k+2) * ddzw(k+1) * rho_air_zw(k+1) +        &
117                         ddzu_pres(k+1) * ddzw(k+1) * rho_air_zw(k) )
118       ENDDO
119!
120!--    Calculate constant coefficients of the tridiagonal matrix
121       CALL maketri
122       CALL split
123
124#if __acc_fft_device
125       !$ACC ENTER DATA &
126       !$ACC COPYIN(ddzuw(0:nz-1,1:3)) &
127       !$ACC COPYIN(tri(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1,1:2))
128#endif
129
130    END SUBROUTINE tridia_init
131
132
133!------------------------------------------------------------------------------!
134! Description:
135! ------------
136!> Computes the i- and j-dependent component of the matrix
137!> Provide the constant coefficients of the tridiagonal matrix for solution
138!> of the Poisson equation in Fourier space.
139!> The coefficients are computed following the method of
140!> Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
141!> Siano's original version by discretizing the Poisson equation,
142!> before it is Fourier-transformed.
143!------------------------------------------------------------------------------!
144    SUBROUTINE maketri
145
146
147          USE arrays_3d,                                                       &
148              ONLY:  tric, rho_air
149
150          USE control_parameters,                                              &
151              ONLY:  ibc_p_b, ibc_p_t
152
153          USE grid_variables,                                                  &
154              ONLY:  dx, dy
155
156
157          IMPLICIT NONE
158
159          INTEGER(iwp) ::  i    !<
160          INTEGER(iwp) ::  j    !<
161          INTEGER(iwp) ::  k    !<
162          INTEGER(iwp) ::  nnxh !<
163          INTEGER(iwp) ::  nnyh !<
164
165          REAL(wp)    ::  ll(nxl_z:nxr_z,nys_z:nyn_z) !<
166
167
168          nnxh = ( nx + 1 ) / 2
169          nnyh = ( ny + 1 ) / 2
170
171          DO  j = nys_z, nyn_z
172             DO  i = nxl_z, nxr_z
173                IF ( j >= 0  .AND.  j <= nnyh )  THEN
174                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
175                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
176                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
177                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
178                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
179                   ELSE
180                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
181                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
182                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
183                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
184                   ENDIF
185                ELSE
186                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
187                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
188                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
189                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
190                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
191                   ELSE
192                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
193                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
194                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
195                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
196                   ENDIF
197                ENDIF
198             ENDDO
199          ENDDO
200
201          DO  k = 0, nz-1
202             DO  j = nys_z, nyn_z
203                DO  i = nxl_z, nxr_z
204                   tric(i,j,k) = ddzuw(k,3) - ll(i,j) * rho_air(k+1)
205                ENDDO
206             ENDDO
207          ENDDO
208
209          IF ( ibc_p_b == 1 )  THEN
210             DO  j = nys_z, nyn_z
211                DO  i = nxl_z, nxr_z
212                   tric(i,j,0) = tric(i,j,0) + ddzuw(0,1)
213                ENDDO
214             ENDDO
215          ENDIF
216          IF ( ibc_p_t == 1 )  THEN
217             DO  j = nys_z, nyn_z
218                DO  i = nxl_z, nxr_z
219                   tric(i,j,nz-1) = tric(i,j,nz-1) + ddzuw(nz-1,2)
220                ENDDO
221             ENDDO
222          ENDIF
223
224    END SUBROUTINE maketri
225
226
227!------------------------------------------------------------------------------!
228! Description:
229! ------------
230!> Substitution (Forward and Backward) (Thomas algorithm)
231!------------------------------------------------------------------------------!
232    SUBROUTINE tridia_substi( ar )
233
234
235          USE arrays_3d,                                                       & 
236              ONLY:  tri
237
238          USE control_parameters,                                              &
239              ONLY:  ibc_p_b, ibc_p_t
240
241          IMPLICIT NONE
242
243          INTEGER(iwp) ::  i !<
244          INTEGER(iwp) ::  j !<
245          INTEGER(iwp) ::  k !<
246
247          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !<
248
249          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1)   ::  ar1 !<
250#if __acc_fft_device
251          !$ACC DECLARE CREATE(ar1)
252#endif
253
254          !$OMP PARALLEL PRIVATE(i,j,k)
255
256!
257!--       Forward substitution
258#if __acc_fft_device
259          !$ACC PARALLEL PRESENT(ar, ar1, tri) PRIVATE(i,j,k)
260#endif
261          DO  k = 0, nz - 1
262#if __acc_fft_device
263             !$ACC LOOP COLLAPSE(2)
264#endif
265             !$OMP DO
266             DO  j = nys_z, nyn_z
267                DO  i = nxl_z, nxr_z
268
269                   IF ( k == 0 )  THEN
270                      ar1(i,j,k) = ar(i,j,k+1)
271                   ELSE
272                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,j,k,2) * ar1(i,j,k-1)
273                   ENDIF
274
275                ENDDO
276             ENDDO
277          ENDDO
278#if __acc_fft_device
279          !$ACC END PARALLEL
280#endif
281
282!
283!--       Backward substitution
284!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
285!--       by zero appearing if the pressure bc is set to neumann at the top of
286!--       the model domain.
287#if __acc_fft_device
288          !$ACC PARALLEL PRESENT(ar, ar1, ddzuw, tri) PRIVATE(i,j,k)
289#endif
290          DO  k = nz-1, 0, -1
291#if __acc_fft_device
292             !$ACC LOOP COLLAPSE(2)
293#endif
294             !$OMP DO
295             DO  j = nys_z, nyn_z
296                DO  i = nxl_z, nxr_z
297
298                   IF ( k == nz-1 )  THEN
299                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,j,k,1) + 1.0E-20_wp )
300                   ELSE
301                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
302                              / tri(i,j,k,1)
303                   ENDIF
304                ENDDO
305             ENDDO
306          ENDDO
307#if __acc_fft_device
308          !$ACC END PARALLEL
309#endif
310
311          !$OMP END PARALLEL
312
313!
314!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
315!--       The respective values of ar should be zero at all k-levels if
316!--       acceleration of horizontally averaged vertical velocity is zero.
317          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
318             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
319#if __acc_fft_device
320                !$ACC PARALLEL LOOP PRESENT(ar)
321#endif
322                DO  k = 1, nz
323                   ar(nxl_z,nys_z,k) = 0.0_wp
324                ENDDO
325             ENDIF
326          ENDIF
327
328    END SUBROUTINE tridia_substi
329
330
331!------------------------------------------------------------------------------!
332! Description:
333! ------------
334!> Substitution (Forward and Backward) (Thomas algorithm)
335!------------------------------------------------------------------------------!
336    SUBROUTINE tridia_substi_overlap( ar, jj )
337
338
339          USE arrays_3d,                                                       &
340              ONLY:  tri
341
342          USE control_parameters,                                              &
343              ONLY:  ibc_p_b, ibc_p_t
344
345          IMPLICIT NONE
346
347          INTEGER(iwp) ::  i  !<
348          INTEGER(iwp) ::  j  !<
349          INTEGER(iwp) ::  jj !<
350          INTEGER(iwp) ::  k  !<
351
352          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !<
353
354          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1) ::  ar1 !<
355
356!
357!--       Forward substitution
358          DO  k = 0, nz - 1
359             DO  j = nys_z, nyn_z
360                DO  i = nxl_z, nxr_z
361
362                   IF ( k == 0 )  THEN
363                      ar1(i,j,k) = ar(i,j,k+1)
364                   ELSE
365                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,jj,k,2) * ar1(i,j,k-1)
366                   ENDIF
367
368                ENDDO
369             ENDDO
370          ENDDO
371
372!
373!--       Backward substitution
374!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
375!--       by zero appearing if the pressure bc is set to neumann at the top of
376!--       the model domain.
377          DO  k = nz-1, 0, -1
378             DO  j = nys_z, nyn_z
379                DO  i = nxl_z, nxr_z
380
381                   IF ( k == nz-1 )  THEN
382                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,jj,k,1) + 1.0E-20_wp )
383                   ELSE
384                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
385                              / tri(i,jj,k,1)
386                   ENDIF
387                ENDDO
388             ENDDO
389          ENDDO
390
391!
392!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
393!--       The respective values of ar should be zero at all k-levels if
394!--       acceleration of horizontally averaged vertical velocity is zero.
395          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
396             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
397                DO  k = 1, nz
398                   ar(nxl_z,nys_z,k) = 0.0_wp
399                ENDDO
400             ENDIF
401          ENDIF
402
403    END SUBROUTINE tridia_substi_overlap
404
405
406!------------------------------------------------------------------------------!
407! Description:
408! ------------
409!> Splitting of the tridiagonal matrix (Thomas algorithm)
410!------------------------------------------------------------------------------!
411    SUBROUTINE split
412
413
414          USE arrays_3d,                                                       & 
415              ONLY:  tri, tric
416
417          IMPLICIT NONE
418
419          INTEGER(iwp) ::  i !<
420          INTEGER(iwp) ::  j !<
421          INTEGER(iwp) ::  k !<
422!
423!--       Splitting
424          DO  j = nys_z, nyn_z
425             DO  i = nxl_z, nxr_z
426                tri(i,j,0,1) = tric(i,j,0)
427             ENDDO
428          ENDDO
429
430          DO  k = 1, nz-1
431             DO  j = nys_z, nyn_z
432                DO  i = nxl_z, nxr_z
433                   tri(i,j,k,2) = ddzuw(k,1) / tri(i,j,k-1,1)
434                   tri(i,j,k,1) = tric(i,j,k) - ddzuw(k-1,2) * tri(i,j,k,2)
435                ENDDO
436             ENDDO
437          ENDDO
438
439    END SUBROUTINE split
440
441
442!------------------------------------------------------------------------------!
443! Description:
444! ------------
445!> Solves the linear system of equations for a 1d-decomposition along x (see
446!> tridia)
447!>
448!> @attention when using the intel compilers older than 12.0, array tri must
449!>            be passed as an argument to the contained subroutines. Otherwise
450!>            addres faults will occur. This feature can be activated with
451!>            cpp-switch __intel11
452!>            On NEC, tri should not be passed (except for routine substi_1dd)
453!>            because this causes very bad performance.
454!------------------------------------------------------------------------------!
455 
456    SUBROUTINE tridia_1dd( ddx2, ddy2, nx, ny, j, ar, tri_for_1d )
457
458
459       USE arrays_3d,                                                          &
460           ONLY:  ddzu_pres, ddzw, rho_air, rho_air_zw
461
462       USE control_parameters,                                                 &
463           ONLY:  ibc_p_b, ibc_p_t
464
465       IMPLICIT NONE
466
467       INTEGER(iwp) ::  i                  !<
468       INTEGER(iwp) ::  j                  !<
469       INTEGER(iwp) ::  k                  !<
470       INTEGER(iwp) ::  nnyh               !<
471       INTEGER(iwp) ::  nx                 !<
472       INTEGER(iwp) ::  ny                 !<
473
474       REAL(wp)     ::  ddx2 !<
475       REAL(wp)     ::  ddy2 !<
476
477       REAL(wp), DIMENSION(0:nx,1:nz)     ::  ar         !<
478       REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !<
479
480
481       nnyh = ( ny + 1 ) / 2
482
483!
484!--    Define constant elements of the tridiagonal matrix.
485!--    The compiler on SX6 does loop exchange. If 0:nx is a high power of 2,
486!--    the exchanged loops create bank conflicts. The following directive
487!--    prohibits loop exchange and the loops perform much better.
488!CDIR NOLOOPCHG
489       DO  k = 0, nz-1
490          DO  i = 0,nx
491             tri_for_1d(2,i,k) = ddzu_pres(k+1) * ddzw(k+1) * rho_air_zw(k)
492             tri_for_1d(3,i,k) = ddzu_pres(k+2) * ddzw(k+1) * rho_air_zw(k+1)
493          ENDDO
494       ENDDO
495
496       IF ( j <= nnyh )  THEN
497          CALL maketri_1dd( j )
498       ELSE
499          CALL maketri_1dd( ny+1-j )
500       ENDIF
501
502       CALL split_1dd
503       CALL substi_1dd( ar, tri_for_1d )
504
505    CONTAINS
506
507
508!------------------------------------------------------------------------------!
509! Description:
510! ------------
511!> computes the i- and j-dependent component of the matrix
512!------------------------------------------------------------------------------!
513       SUBROUTINE maketri_1dd( j )
514
515          IMPLICIT NONE
516
517          INTEGER(iwp) ::  i    !<
518          INTEGER(iwp) ::  j    !<
519          INTEGER(iwp) ::  k    !<
520          INTEGER(iwp) ::  nnxh !<
521
522          REAL(wp)     ::  a !<
523          REAL(wp)     ::  c !<
524
525          REAL(wp), DIMENSION(0:nx) ::  l !<
526
527
528          nnxh = ( nx + 1 ) / 2
529!
530!--       Provide the tridiagonal matrix for solution of the Poisson equation in
531!--       Fourier space. The coefficients are computed following the method of
532!--       Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
533!--       Siano's original version by discretizing the Poisson equation,
534!--       before it is Fourier-transformed
535          DO  i = 0, nx
536             IF ( i >= 0 .AND. i <= nnxh ) THEN
537                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
538                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
539                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
540                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
541             ELSE
542                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
543                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
544                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
545                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
546             ENDIF
547          ENDDO
548
549          DO  k = 0, nz-1
550             DO  i = 0, nx
551                a = -1.0_wp * ddzu_pres(k+2) * ddzw(k+1) * rho_air_zw(k+1)
552                c = -1.0_wp * ddzu_pres(k+1) * ddzw(k+1) * rho_air_zw(k)
553                tri_for_1d(1,i,k) = a + c - l(i) * rho_air(k+1)
554             ENDDO
555          ENDDO
556          IF ( ibc_p_b == 1 )  THEN
557             DO  i = 0, nx
558                tri_for_1d(1,i,0) = tri_for_1d(1,i,0) + tri_for_1d(2,i,0)
559             ENDDO
560          ENDIF
561          IF ( ibc_p_t == 1 )  THEN
562             DO  i = 0, nx
563                tri_for_1d(1,i,nz-1) = tri_for_1d(1,i,nz-1) + tri_for_1d(3,i,nz-1)
564             ENDDO
565          ENDIF
566
567       END SUBROUTINE maketri_1dd
568
569
570!------------------------------------------------------------------------------!
571! Description:
572! ------------
573!> Splitting of the tridiagonal matrix (Thomas algorithm)
574!------------------------------------------------------------------------------!
575       SUBROUTINE split_1dd
576
577          IMPLICIT NONE
578
579          INTEGER(iwp) ::  i !<
580          INTEGER(iwp) ::  k !<
581
582
583!
584!--       Splitting
585          DO  i = 0, nx
586             tri_for_1d(4,i,0) = tri_for_1d(1,i,0)
587          ENDDO
588          DO  k = 1, nz-1
589             DO  i = 0, nx
590                tri_for_1d(5,i,k) = tri_for_1d(2,i,k) / tri_for_1d(4,i,k-1)
591                tri_for_1d(4,i,k) = tri_for_1d(1,i,k) - tri_for_1d(3,i,k-1) * tri_for_1d(5,i,k)
592             ENDDO
593          ENDDO
594
595       END SUBROUTINE split_1dd
596
597
598!------------------------------------------------------------------------------!
599! Description:
600! ------------
601!> Substitution (Forward and Backward) (Thomas algorithm)
602!------------------------------------------------------------------------------!
603       SUBROUTINE substi_1dd( ar, tri_for_1d )
604
605
606          IMPLICIT NONE
607
608          INTEGER(iwp) ::  i !<
609          INTEGER(iwp) ::  k !<
610
611          REAL(wp), DIMENSION(0:nx,nz)       ::  ar         !<
612          REAL(wp), DIMENSION(0:nx,0:nz-1)   ::  ar1        !<
613          REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !<
614
615!
616!--       Forward substitution
617          DO  i = 0, nx
618             ar1(i,0) = ar(i,1)
619          ENDDO
620          DO  k = 1, nz-1
621             DO  i = 0, nx
622                ar1(i,k) = ar(i,k+1) - tri_for_1d(5,i,k) * ar1(i,k-1)
623             ENDDO
624          ENDDO
625
626!
627!--       Backward substitution
628!--       Note, the add of 1.0E-20 in the denominator is due to avoid divisions
629!--       by zero appearing if the pressure bc is set to neumann at the top of
630!--       the model domain.
631          DO  i = 0, nx
632             ar(i,nz) = ar1(i,nz-1) / ( tri_for_1d(4,i,nz-1) + 1.0E-20_wp )
633          ENDDO
634          DO  k = nz-2, 0, -1
635             DO  i = 0, nx
636                ar(i,k+1) = ( ar1(i,k) - tri_for_1d(3,i,k) * ar(i,k+2) ) &
637                            / tri_for_1d(4,i,k)
638             ENDDO
639          ENDDO
640
641!
642!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
643!--       The respective values of ar should be zero at all k-levels if
644!--       acceleration of horizontally averaged vertical velocity is zero.
645          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
646             IF ( j == 0 )  THEN
647                DO  k = 1, nz
648                   ar(0,k) = 0.0_wp
649                ENDDO
650             ENDIF
651          ENDIF
652
653       END SUBROUTINE substi_1dd
654
655    END SUBROUTINE tridia_1dd
656
657
658 END MODULE tridia_solver
Note: See TracBrowser for help on using the repository browser.