1 | MODULE kinetic_mod |
---|
2 | IMPLICIT NONE |
---|
3 | PRIVATE |
---|
4 | |
---|
5 | PUBLIC :: kinetic, kinetic_v, kinetic_new, gradient |
---|
6 | |
---|
7 | CONTAINS |
---|
8 | |
---|
9 | SUBROUTINE kinetic(f_ue,f_Ki) |
---|
10 | USE icosa |
---|
11 | IMPLICIT NONE |
---|
12 | TYPE(t_field), POINTER :: f_ue(:) |
---|
13 | TYPE(t_field), POINTER :: f_Ki(:) |
---|
14 | |
---|
15 | REAL(rstd), POINTER :: ue(:,:) |
---|
16 | REAL(rstd), POINTER :: Ki(:,:) |
---|
17 | INTEGER :: ind |
---|
18 | |
---|
19 | CALL transfert_request(f_ue,req_e1_vect) |
---|
20 | CALL transfert_request(f_ue,req_e1_vect) |
---|
21 | |
---|
22 | DO ind=1,ndomain |
---|
23 | IF (.NOT. assigned_domain(ind)) CYCLE |
---|
24 | CALL swap_dimensions(ind) |
---|
25 | CALL swap_geometry(ind) |
---|
26 | ue=f_ue(ind) |
---|
27 | Ki=f_Ki(ind) |
---|
28 | CALL compute_kinetic(ue, Ki) |
---|
29 | ENDDO |
---|
30 | END SUBROUTINE kinetic |
---|
31 | |
---|
32 | SUBROUTINE kinetic_new(f_ue,f_Ki) |
---|
33 | USE icosa |
---|
34 | IMPLICIT NONE |
---|
35 | TYPE(t_field), POINTER :: f_ue(:) |
---|
36 | TYPE(t_field), POINTER :: f_Ki(:) |
---|
37 | |
---|
38 | REAL(rstd), POINTER :: ue(:,:) |
---|
39 | REAL(rstd), POINTER :: Ki(:,:) |
---|
40 | INTEGER :: ind |
---|
41 | |
---|
42 | CALL transfert_request(f_ue,req_e1_vect) |
---|
43 | CALL transfert_request(f_ue,req_e1_vect) |
---|
44 | |
---|
45 | DO ind=1,ndomain |
---|
46 | IF (.NOT. assigned_domain(ind)) CYCLE |
---|
47 | CALL swap_dimensions(ind) |
---|
48 | CALL swap_geometry(ind) |
---|
49 | ue=f_ue(ind) |
---|
50 | Ki=f_Ki(ind) |
---|
51 | CALL compute_Ki_new(ue, Ki) |
---|
52 | ENDDO |
---|
53 | END SUBROUTINE kinetic_new |
---|
54 | |
---|
55 | SUBROUTINE kinetic_v(f_ue,f_Kv) |
---|
56 | USE icosa |
---|
57 | IMPLICIT NONE |
---|
58 | TYPE(t_field), POINTER :: f_ue(:) |
---|
59 | TYPE(t_field), POINTER :: f_Kv(:) |
---|
60 | |
---|
61 | REAL(rstd), POINTER :: ue(:,:) |
---|
62 | REAL(rstd), POINTER :: Kv(:,:) |
---|
63 | INTEGER :: ind |
---|
64 | |
---|
65 | CALL transfert_request(f_ue,req_e1_vect) |
---|
66 | CALL transfert_request(f_ue,req_e1_vect) |
---|
67 | |
---|
68 | DO ind=1,ndomain |
---|
69 | IF (.NOT. assigned_domain(ind)) CYCLE |
---|
70 | CALL swap_dimensions(ind) |
---|
71 | CALL swap_geometry(ind) |
---|
72 | ue=f_ue(ind) |
---|
73 | Kv=f_Kv(ind) |
---|
74 | CALL compute_kv(ue, Kv) |
---|
75 | ENDDO |
---|
76 | END SUBROUTINE kinetic_v |
---|
77 | |
---|
78 | SUBROUTINE compute_kinetic(ue, Ki) |
---|
79 | USE icosa |
---|
80 | USE omp_para |
---|
81 | IMPLICIT NONE |
---|
82 | REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm) |
---|
83 | REAL(rstd),INTENT(OUT) :: Ki(iim*jjm,llm) |
---|
84 | INTEGER :: i,j,ij,l |
---|
85 | |
---|
86 | DO l=ll_begin,ll_end |
---|
87 | DO j=jj_begin,jj_end |
---|
88 | DO i=ii_begin,ii_end |
---|
89 | ij=(j-1)*iim+i |
---|
90 | |
---|
91 | Ki(ij,l)=1/(4*Ai(ij))*(le(ij+u_right)*de(ij+u_right)*ue(ij+u_right,l)**2 + & |
---|
92 | le(ij+u_rup)*de(ij+u_rup)*ue(ij+u_rup,l)**2 + & |
---|
93 | le(ij+u_lup)*de(ij+u_lup)*ue(ij+u_lup,l)**2 + & |
---|
94 | le(ij+u_left)*de(ij+u_left)*ue(ij+u_left,l)**2 + & |
---|
95 | le(ij+u_ldown)*de(ij+u_ldown)*ue(ij+u_ldown,l)**2 + & |
---|
96 | le(ij+u_rdown)*de(ij+u_rdown)*ue(ij+u_rdown,l)**2 ) |
---|
97 | |
---|
98 | ENDDO |
---|
99 | ENDDO |
---|
100 | ENDDO |
---|
101 | END SUBROUTINE compute_kinetic |
---|
102 | |
---|
103 | SUBROUTINE compute_kv(ue, Kv) |
---|
104 | USE icosa |
---|
105 | USE omp_para |
---|
106 | IMPLICIT NONE |
---|
107 | REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm) |
---|
108 | REAL(rstd),INTENT(OUT) :: Kv(2*iim*jjm,llm) |
---|
109 | INTEGER :: ij,l, u_up, u_down |
---|
110 | |
---|
111 | u_up = t_lup + u_right |
---|
112 | u_down = t_rdown + u_left |
---|
113 | |
---|
114 | DO l=ll_begin,ll_end |
---|
115 | DO ij=ij_begin,ij_end |
---|
116 | Kv(ij+z_up,l) = (radius**2/Av(ij+z_up))*( & |
---|
117 | S1(ij,vup)*ue(ij+u_rup,l)**2 + & |
---|
118 | S2(ij,vup)*ue(ij+u_lup,l)**2 + & |
---|
119 | S2(ij+t_lup,vrdown)*ue(ij+u_up,l)**2) |
---|
120 | |
---|
121 | Kv(ij+z_down,l) = (radius**2/Av(ij+z_down))*( & |
---|
122 | S1(ij,vdown)*ue(ij+u_ldown,l)**2 + & |
---|
123 | S2(ij,vdown)*ue(ij+u_rdown,l)**2 + & |
---|
124 | S2(ij+t_rdown,vlup)*ue(ij+u_down,l)**2 ) |
---|
125 | ENDDO |
---|
126 | ENDDO |
---|
127 | END SUBROUTINE compute_kv |
---|
128 | |
---|
129 | SUBROUTINE compute_Ki_new(ue, Ki) |
---|
130 | USE icosa |
---|
131 | USE omp_para |
---|
132 | IMPLICIT NONE |
---|
133 | REAL(rstd),INTENT(IN) :: ue(3*iim*jjm,llm) |
---|
134 | REAL(rstd),INTENT(OUT):: Ki(iim*jjm,llm) |
---|
135 | REAL(rstd) :: Kv(2*iim*jjm,llm) |
---|
136 | INTEGER :: ij,l, u_up, u_down |
---|
137 | |
---|
138 | CALL compute_kv(ue,Kv) |
---|
139 | |
---|
140 | DO l=ll_begin,ll_end |
---|
141 | DO ij=ij_begin,ij_end |
---|
142 | Ki(ij,l) = Riv(ij,vup)*Kv(ij+z_up,l) + & |
---|
143 | Riv(ij,vlup) *Kv(ij+z_lup,l) + & |
---|
144 | Riv(ij,vldown)*Kv(ij+z_ldown,l) + & |
---|
145 | Riv(ij,vdown) *Kv(ij+z_down,l) + & |
---|
146 | Riv(ij,vrdown)*Kv(ij+z_rdown,l) + & |
---|
147 | Riv(ij,vrup) *Kv(ij+z_rup,l) |
---|
148 | END DO |
---|
149 | END DO |
---|
150 | END SUBROUTINE compute_Ki_new |
---|
151 | |
---|
152 | SUBROUTINE gradient(f_berni, f_du) |
---|
153 | USE icosa |
---|
154 | IMPLICIT NONE |
---|
155 | TYPE(t_field), POINTER :: f_berni(:) |
---|
156 | TYPE(t_field), POINTER :: f_du(:) |
---|
157 | |
---|
158 | REAL(rstd), POINTER :: du(:,:) |
---|
159 | REAL(rstd), POINTER :: berni(:,:) |
---|
160 | INTEGER :: ind |
---|
161 | |
---|
162 | CALL transfert_request(f_du,req_e1_vect) |
---|
163 | CALL transfert_request(f_du,req_e1_vect) |
---|
164 | |
---|
165 | DO ind=1,ndomain |
---|
166 | IF (.NOT. assigned_domain(ind)) CYCLE |
---|
167 | CALL swap_dimensions(ind) |
---|
168 | CALL swap_geometry(ind) |
---|
169 | berni=f_berni(ind) |
---|
170 | du=f_du(ind) |
---|
171 | CALL compute_grad(berni, du) |
---|
172 | ENDDO |
---|
173 | |
---|
174 | END SUBROUTINE gradient |
---|
175 | |
---|
176 | SUBROUTINE compute_grad(berni, du) |
---|
177 | USE icosa |
---|
178 | USE omp_para |
---|
179 | IMPLICIT NONE |
---|
180 | REAL(rstd),INTENT(IN) :: berni(iim*jjm,llm) |
---|
181 | REAL(rstd),INTENT(OUT) :: du(3*iim*jjm,llm) |
---|
182 | INTEGER :: i,j,ij,l |
---|
183 | |
---|
184 | DO l=ll_begin,ll_end |
---|
185 | DO j=jj_begin,jj_end |
---|
186 | DO i=ii_begin,ii_end |
---|
187 | ij=(j-1)*iim+i |
---|
188 | du(ij+u_right,l) = ne_right*(berni(ij,l)-berni(ij+t_right,l))/de(ij+u_right) |
---|
189 | du(ij+u_lup,l) = ne_lup*(berni(ij,l)-berni(ij+t_lup,l))/de(ij+u_right) |
---|
190 | du(ij+u_ldown,l) = ne_ldown*(berni(ij,l)-berni(ij+t_ldown,l))/de(ij+u_right) |
---|
191 | ENDDO |
---|
192 | ENDDO |
---|
193 | ENDDO |
---|
194 | |
---|
195 | END SUBROUTINE compute_grad |
---|
196 | |
---|
197 | |
---|
198 | END MODULE kinetic_mod |
---|