module_positive_definite.F
References to this file elsewhere.
1 MODULE module_positive_definite
2
3 USE module_wrf_error ! frame
4
5 CONTAINS
6
7 SUBROUTINE positive_definite_slab( f, &
8 ids, ide, jds, jde, kds, kde, &
9 ims, ime, jms, jme, kms, kme, &
10 its, ite, jts, jte, kts, kte)
11
12 IMPLICIT NONE
13
14 ! Arguments
15 INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
16 ims, ime, jms, jme, kms, kme, &
17 its, ite, jts, jte, kts, kte
18 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: f
19
20 ! Local variables
21 REAL, DIMENSION(:), ALLOCATABLE :: line
22 INTEGER :: j, k, i_end, j_end, k_end
23 REAL :: fmin, ftotal_pre, rftotal_post
24
25 ! Initialize variables
26 i_end = ide-1
27 j_end = MIN(jte, jde-1)
28 k_end = kte-1
29 ! Only do anything if we have to...
30 IF (ANY(f(ids:i_end,kts:k_end,jts:j_end) < 0.)) THEN
31 ! number of points in the X direction, not including U-stagger
32 ALLOCATE(line(ide-ids))
33 DO j = jts, j_end
34 DO k = kts, kte-1
35 !while_lt_0_loop: DO WHILE (ANY(f(ids:i_end,k,j) < 0.))
36 f_lt_0: IF (ANY(f(ids:i_end,k,j) < 0.)) THEN
37 line(:) = f(ids:i_end,k,j)
38 ! This is actually an integration over x assuming dx is constant
39 ftotal_pre = SUM(line)
40 ! If the total is negative, set everything to 0. and exit
41 IF (ftotal_pre < 0.) THEN
42 line(:) = 0.
43 ELSE
44 ! Value to add to array to make sure every element is > 0.
45 fmin = MINVAL(line)
46 line(:) = line(:) - fmin ! fmin is negative...
47 rftotal_post = 1./SUM(line)
48 line = line*ftotal_pre*rftotal_post
49 ! The following error can naturally occur on 32-bit machines:
50 !IF (SUM(line) /= ftotal_pre) THEN
51 ! write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
52 ! 'mismatching sums ',j,k,ftotal_pre,&
53 ! SUM(line),fmin,1./rftotal_post
54 ! write(*,*) line
55 ! CALL wrf_error_fatal( wrf_err_message )
56 !END IF
57 END IF
58 f(ids:i_end,k,j) = line(:)
59 END IF f_lt_0
60 !END DO while_lt_0_loop
61 END DO
62 END DO
63 DEALLOCATE(line)
64 END IF
65
66 END SUBROUTINE positive_definite_slab
67
68 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
69
70 SUBROUTINE positive_definite_sheet( f, f_total, nx, ny )
71
72 IMPLICIT NONE
73
74 ! Arguments
75 INTEGER, INTENT(IN ) :: nx, ny
76 REAL, DIMENSION( nx, ny ), INTENT(INOUT) :: f
77 REAL, DIMENSION( ny ), INTENT(IN) :: f_total
78
79 ! Local variables
80 REAL, DIMENSION(:), ALLOCATABLE :: line
81 INTEGER :: iy
82 REAL :: fmin, rftotal_post, sum_line
83 REAL, PARAMETER :: eps = 1.0e-15
84
85 ! Only do anything if we have to...
86 IF (ANY(f < 0.)) THEN
87 ALLOCATE(line(nx))
88 DO iy = 1, ny
89 !while_lt_0_loop: DO WHILE (ANY(f(:,iy) < 0.))
90 f_lt_0: IF (ANY(f(:,iy) < 0.)) THEN
91 line(:) = f(:,iy)
92 ! If the total is negative, set everything to 0. and exit
93 IF (f_total(iy) < 0.) THEN
94 line(:) = 0.
95 ELSE
96 ! Value to add to array to make sure every element is > 0.
97 fmin = MINVAL(line)
98 line(:) = line(:) - fmin ! fmin is negative...
99 sum_line = SUM(line)
100 IF(sum_line > eps) THEN
101 rftotal_post = 1./sum_line
102 line = line*f_total(iy)*rftotal_post
103 ELSE
104 line(:) = 0.
105 END IF
106 ! The following error can naturally occur on 32-bit machines:
107 !IF (SUM(line) /= f_total(iy)) THEN
108 ! write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
109 ! 'mismatching sums ',iy,f_total(iy), &
110 ! SUM(line),fmin,1./rftotal_post
111 ! write(*,*) line
112 ! CALL wrf_error_fatal( wrf_err_message )
113 !END IF
114 END IF
115 f(:,iy) = line(:)
116 END IF f_lt_0
117 !END DO while_lt_0_loop
118 END DO
119 DEALLOCATE(line)
120 END IF
121
122 END SUBROUTINE positive_definite_sheet
123
124 END MODULE module_positive_definite