source: codes/icosagcm/trunk/src/diagnostics/kinetic.f90

Last change on this file was 899, checked in by adurocher, 5 years ago

trunk : Fixed GCC warnings

Fixed iso c bindings
fixed warnings with -Wall -Wno-aliasing -Wno-unused -Wno-unused-dummy-argument -Wno-maybe-uninitialized -Wno-tabs warnings
Removed all unused variables (-Wunused-variable)
vector%dot_product is now dot_product_3d to avoid compilation warning "dot_product shadows intrinsic" with GCC
File size: 5.5 KB
Line 
1MODULE kinetic_mod
2IMPLICIT NONE
3PRIVATE
4
5PUBLIC :: kinetic, kinetic_v, kinetic_new, gradient
6
7CONTAINS
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
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
198END MODULE kinetic_mod
Note: See TracBrowser for help on using the repository browser.