[12] | 1 | MODULE kinetic_mod |
---|
[427] | 2 | IMPLICIT NONE |
---|
| 3 | PRIVATE |
---|
[12] | 4 | |
---|
[427] | 5 | PUBLIC :: kinetic, kinetic_v, kinetic_new, gradient |
---|
[12] | 6 | |
---|
| 7 | CONTAINS |
---|
| 8 | |
---|
| 9 | SUBROUTINE kinetic(f_ue,f_Ki) |
---|
[19] | 10 | USE icosa |
---|
[12] | 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 | |
---|
[146] | 19 | CALL transfert_request(f_ue,req_e1_vect) |
---|
| 20 | CALL transfert_request(f_ue,req_e1_vect) |
---|
[12] | 21 | |
---|
| 22 | DO ind=1,ndomain |
---|
[186] | 23 | IF (.NOT. assigned_domain(ind)) CYCLE |
---|
[12] | 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) |
---|
[427] | 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) |
---|
[12] | 52 | ENDDO |
---|
[427] | 53 | END SUBROUTINE kinetic_new |
---|
[12] | 54 | |
---|
[427] | 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(:) |
---|
[12] | 60 | |
---|
[427] | 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 | |
---|
[12] | 78 | SUBROUTINE compute_kinetic(ue, Ki) |
---|
[19] | 79 | USE icosa |
---|
[295] | 80 | USE omp_para |
---|
[12] | 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 | |
---|
[295] | 86 | DO l=ll_begin,ll_end |
---|
[12] | 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 |
---|
[427] | 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 |
---|
[12] | 113 | |
---|
[427] | 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 |
---|
[12] | 128 | |
---|
[427] | 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 | |
---|
[12] | 198 | END MODULE kinetic_mod |
---|