source: codes/icosagcm/trunk/src/physics/physics_interface.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: 10.9 KB
Line 
1MODULE physics_interface_mod
2
3  USE prec
4
5  PRIVATE
6
7  TYPE t_physics_inout
8     ! Input, time-independent
9     INTEGER :: ngrid
10     REAL(rstd) :: dt_phys
11     REAL(rstd), DIMENSION(:), POINTER :: Ai, lon, lat, phis
12     ! Input, time-dependent
13     REAL(rstd), DIMENSION(:,:), POINTER :: p, pk, Temp, ulon, ulat
14     REAL(rstd), DIMENSION(:,:,:), POINTER :: q
15     ! Output arrays
16     REAL(rstd), DIMENSION(:,:), POINTER :: dTemp, dulon, dulat
17     REAL(rstd), DIMENSION(:,:,:), POINTER :: dq
18  END TYPE t_physics_inout
19
20! physics_inout is used to exchange information with physics
21! Field ngrid is initialized by physics.f90/init_physics. Its other fields
22! must be defined by XX/init_physics (where XX =  e.g. physics_dcmip.f90)
23! by either pointing to internal data of the physics package
24! or by a specific allocation
25! size : (ngrid), (ngrid,llm) except p(ngrid,llm+1), (ngrid,llm,nqtot)
26
27  TYPE(t_physics_inout), SAVE :: physics_inout
28!$OMP THREADPRIVATE(physics_inout)
29 
30! pack_info contains indices used by pack/unpack routines
31! to pack together the data of all the domains managed by the MPI process
32! It is initialized by physics.f90/init_physics
33
34  TYPE t_pack_info
35     INTEGER :: ngrid, & ! number of non-halo points in that domain
36          nseg ! number of segments (contigous parts) in that domain
37     ! size and start of each segment : ij domain index, k packed index
38     INTEGER, ALLOCATABLE :: n(:), ij(:), k(:)
39  END TYPE t_pack_info
40
41  TYPE(t_pack_info), ALLOCATABLE, SAVE :: pack_info(:)
42!$OMP THREADPRIVATE(pack_info)
43
44
45  INTERFACE pack_field
46     MODULE PROCEDURE pack_2D
47     MODULE PROCEDURE pack_3D
48     MODULE PROCEDURE pack_4D
49  END INTERFACE pack_field
50
51  INTERFACE unpack_field
52     MODULE PROCEDURE unpack_2D
53     MODULE PROCEDURE unpack_3D
54     MODULE PROCEDURE unpack_4D
55  END INTERFACE unpack_field
56
57  INTERFACE pack_domain
58     MODULE PROCEDURE pack_domain_2D
59     MODULE PROCEDURE pack_domain_3D
60     MODULE PROCEDURE pack_domain_4D
61  END INTERFACE pack_domain
62
63  INTERFACE unpack_domain
64     MODULE PROCEDURE unpack_domain_2D
65     MODULE PROCEDURE unpack_domain_3D
66     MODULE PROCEDURE unpack_domain_4D
67  END INTERFACE unpack_domain
68
69  PUBLIC :: nb_extra_physics_2D, nb_extra_physics_3D, &
70       t_physics_inout, physics_inout, &
71       t_pack_info, pack_info, init_pack_before, init_pack_after, &
72       pack_domain, pack_field, unpack_domain, unpack_field, &
73       garbage_3D
74
75CONTAINS
76 
77    SUBROUTINE init_pack_before
78    USE icosa
79    IMPLICIT NONE
80    INTEGER :: ind, offset
81
82    offset=0
83    ALLOCATE(pack_info(ndomain))
84    DO ind=1,ndomain
85       IF (.NOT. assigned_domain(ind)) CYCLE
86       CALL swap_dimensions(ind)
87       CALL swap_geometry(ind)
88       CALL count_segments(domain(ind)%own, pack_info(ind))
89       pack_info(ind)%k = pack_info(ind)%k + offset
90       offset = offset + pack_info(ind)%ngrid
91    END DO
92    physics_inout%ngrid = offset
93
94  END SUBROUTINE init_pack_before
95
96  SUBROUTINE count_segments(own, info)
97    USE icosa
98    IMPLICIT NONE
99    LOGICAL, DIMENSION(:,:) :: own
100    TYPE(t_pack_info) :: info
101
102    INTEGER, DIMENSION(jjm) :: n
103    INTEGER :: ngrid, nseg, i, j, jj, k
104    INTEGER, PARAMETER :: method=4
105    SELECT CASE(method)
106    CASE(1) ! Copy all points, including halo (works)
107       info%nseg=1
108       info%ngrid=iim*jjm
109       ALLOCATE(info%n(1))
110       ALLOCATE(info%ij(1))
111       ALLOCATE(info%k(1))
112       info%n(1)=iim*jjm
113       info%ij(1)=1
114       info%k(1)=1
115    CASE(2) ! Copy all points, including halo, one at a time (works, slow ?)
116       info%nseg=iim*jjm
117       info%ngrid=iim*jjm
118       ALLOCATE(info%n(iim*jjm))
119       ALLOCATE(info%ij(iim*jjm))
120       ALLOCATE(info%k(iim*jjm))
121       DO jj=1,iim*jjm
122          info%n(jj) =1
123          info%ij(jj)=jj
124          info%k(jj) =jj
125       END DO
126    CASE(3) ! Copy non-halo points only, one at a time (works, slow ?)
127       n=0
128       n(jj_begin:jj_end)=COUNT(own(ii_begin:ii_end,jj_begin:jj_end),1)
129       ngrid=SUM(n)
130       info%ngrid=ngrid
131       info%nseg=ngrid
132       ALLOCATE(info%n(ngrid))
133       ALLOCATE(info%ij(ngrid))
134       ALLOCATE(info%k(ngrid))
135       jj=1
136       DO j=1,jjm
137          DO i=1,iim
138             IF(own(i,j)) THEN
139                info%n(jj)=1
140                info%k(jj)=jj
141                info%ij(jj) = iim*(j-1)+i
142                jj=jj+1
143             END IF
144          END DO
145       END DO
146       
147    CASE DEFAULT ! Copy non-halo points only, as contiguous segments (works)
148       n=0
149       n(jj_begin:jj_end)=COUNT(own(ii_begin:ii_end,jj_begin:jj_end),1)
150       ngrid=SUM(n)
151       info%ngrid=ngrid
152       nseg=COUNT(n>0)
153       info%nseg=nseg
154       ALLOCATE(info%n(nseg))
155       ALLOCATE(info%ij(nseg))
156       ALLOCATE(info%k(nseg))
157       info%n(:)=0
158       info%ij(:)=0
159       info%k(:)=0
160       
161       jj=1
162       k=1
163       DO j=jj_begin,jj_end
164          IF(n(j)>0) THEN
165             ! find first .TRUE. value in own(:,j)
166             DO i=ii_begin,ii_end
167                IF(own(i,j)) THEN
168                   info%n(jj)=n(j)
169                   info%k(jj)=k
170                   info%ij(jj) = iim*(j-1)+i
171                   IF(COUNT(own(i:i+n(j)-1,j)) /= n(j)) STOP
172                   EXIT
173                END IF
174             END DO
175             k = k + n(j)
176             jj=jj+1
177          END IF
178       END DO
179
180       IF(k-1/=ngrid) THEN
181          PRINT *, 'Total number of grid points inconsistent', k-1, ngrid
182          STOP
183       END IF
184       IF(jj-1/=nseg) THEN
185          PRINT *, 'Number of segments inconsistent', jj-1, nseg
186          STOP
187       END IF
188
189    END SELECT
190   
191    PRINT *, 'count_segments', info%nseg, info%ngrid, SUM(info%n), COUNT(own), iim*jjm
192  END SUBROUTINE count_segments
193
194  SUBROUTINE init_pack_after
195    USE icosa
196    IMPLICIT NONE
197    INTEGER :: ind
198    DO ind=1,ndomain
199       IF (.NOT. assigned_domain(ind)) CYCLE
200       CALL swap_dimensions(ind)
201       CALL swap_geometry(ind)
202       CALL pack_domain_2D(pack_info(ind), Ai, physics_inout%Ai)
203       CALL pack_domain_2D(pack_info(ind), lon_i, physics_inout%lon)
204       CALL pack_domain_2D(pack_info(ind), lat_i, physics_inout%lat)
205    END DO
206  END SUBROUTINE init_pack_after
207
208!-------------------------------- Pack / Unpack 2D ---------------------------
209
210  SUBROUTINE pack_2D(f_2D, packed)
211    USE icosa
212    IMPLICIT NONE
213    TYPE(t_field),POINTER :: f_2D(:)
214    REAL(rstd)            :: packed(:)
215    REAL(rstd), POINTER   :: loc(:)
216    INTEGER :: ind
217    DO ind=1,ndomain
218       IF (.NOT. assigned_domain(ind)) CYCLE
219       loc = f_2D(ind)
220       CALL pack_domain_2D(pack_info(ind), loc, packed)
221    END DO
222  END SUBROUTINE pack_2D
223
224  SUBROUTINE unpack_2D(f_2D, packed) 
225    USE icosa
226    IMPLICIT NONE
227    TYPE(t_field),POINTER :: f_2D(:)
228    REAL(rstd)            :: packed(:)
229    REAL(rstd), POINTER   :: loc(:)
230    INTEGER :: ind
231    DO ind=1,ndomain
232       IF (.NOT. assigned_domain(ind)) CYCLE
233       loc = f_2D(ind)
234       CALL unpack_domain_2D(pack_info(ind), loc, packed)
235    END DO
236  END SUBROUTINE unpack_2D
237
238  SUBROUTINE pack_domain_2D(info, loc, glob)
239    USE icosa
240    IMPLICIT NONE
241    TYPE(t_pack_info) :: info
242    REAL(rstd), DIMENSION(:) :: loc, glob
243    INTEGER :: jj,n,k,ij
244    DO jj=1, info%nseg
245       n = info%n(jj)-1
246       ij = info%ij(jj)
247       k = info%k(jj)
248       glob(k:k+n) = loc(ij:ij+n)
249    END DO
250  END SUBROUTINE pack_domain_2D
251
252  SUBROUTINE unpack_domain_2D(info, loc, glob)
253    IMPLICIT NONE
254    TYPE(t_pack_info) :: info
255    REAL(rstd), DIMENSION(:) :: loc, glob
256    INTEGER :: jj,n,k,ij
257    DO jj=1, info%nseg
258       n = info%n(jj)-1
259       ij = info%ij(jj)
260       k = info%k(jj)
261       loc(ij:ij+n) = glob(k:k+n)
262    END DO
263  END SUBROUTINE unpack_domain_2D
264
265!-------------------------------- Pack / Unpack 3D ---------------------------
266
267  SUBROUTINE pack_3D(f_3D, packed)
268    USE icosa
269    IMPLICIT NONE
270    TYPE(t_field),POINTER :: f_3D(:)
271    REAL(rstd)            :: packed(:,:)
272    REAL(rstd), POINTER   :: loc(:,:)
273    INTEGER :: ind
274    DO ind=1,ndomain
275       IF (.NOT. assigned_domain(ind)) CYCLE
276       loc = f_3D(ind)
277       CALL pack_domain_3D(pack_info(ind), loc, packed)
278    END DO
279  END SUBROUTINE pack_3D
280
281  SUBROUTINE unpack_3D(f_3D, packed) 
282    USE icosa
283    IMPLICIT NONE
284    TYPE(t_field),POINTER :: f_3D(:)
285    REAL(rstd)            :: packed(:,:)
286    REAL(rstd), POINTER   :: loc(:,:)
287    INTEGER :: ind
288    DO ind=1,ndomain
289       IF (.NOT. assigned_domain(ind)) CYCLE
290       loc = f_3D(ind)
291       CALL unpack_domain_3D(pack_info(ind), loc, packed)
292    END DO
293  END SUBROUTINE unpack_3D
294
295  SUBROUTINE pack_domain_3D(info, loc, glob)
296    IMPLICIT NONE
297    TYPE(t_pack_info) :: info
298    REAL(rstd), DIMENSION(:,:) :: loc, glob
299    INTEGER :: jj,n,k,ij
300    DO jj=1, info%nseg
301       n = info%n(jj)-1
302       ij = info%ij(jj)
303       k = info%k(jj)
304       glob(k:k+n,:) = loc(ij:ij+n,:)
305    END DO
306  END SUBROUTINE pack_domain_3D
307
308  SUBROUTINE unpack_domain_3D(info, loc, glob)
309    IMPLICIT NONE
310    TYPE(t_pack_info) :: info
311    REAL(rstd), DIMENSION(:,:) :: loc, glob
312    INTEGER :: jj,n,k,ij
313    DO jj=1, info%nseg
314       n = info%n(jj)-1
315       ij = info%ij(jj)
316       k = info%k(jj)
317       loc(ij:ij+n,:) = glob(k:k+n,:)
318    END DO   
319  END SUBROUTINE unpack_domain_3D
320
321  SUBROUTINE garbage_3D(loc,own)
322    USE icosa
323    IMPLICIT NONE
324    LOGICAL :: own(iim,jjm)
325    REAL(rstd) :: loc(iim*jjm,llm)
326    INTEGER :: i,j,ij
327    ! write garbage in non-owned points
328    DO j=1,jjm
329       DO i=1,iim
330          IF(.NOT.own(i,j)) THEN
331             ij=iim*(j-1)+i
332             loc(ij,:)=-1e30
333          END IF
334       END DO
335    END DO   
336  END SUBROUTINE garbage_3D
337
338!-------------------------------- Pack / Unpack 4D ---------------------------
339
340  SUBROUTINE pack_4D(f_4D, packed)
341    USE icosa
342    IMPLICIT NONE
343    TYPE(t_field),POINTER :: f_4D(:)
344    REAL(rstd)            :: packed(:,:,:)
345    REAL(rstd), POINTER   :: loc(:,:,:)
346    INTEGER :: ind
347    DO ind=1,ndomain
348       IF (.NOT. assigned_domain(ind)) CYCLE
349       loc = f_4D(ind)
350       CALL pack_domain_4D(pack_info(ind), loc, packed)
351    END DO
352  END SUBROUTINE pack_4D
353
354  SUBROUTINE unpack_4D(f_4D, packed) 
355    USE icosa
356    IMPLICIT NONE
357    TYPE(t_field),POINTER :: f_4D(:)
358    REAL(rstd)            :: packed(:,:,:)
359    REAL(rstd), POINTER   :: loc(:,:,:)
360    INTEGER :: ind
361    DO ind=1,ndomain
362       IF (.NOT. assigned_domain(ind)) CYCLE
363       loc = f_4D(ind)
364       CALL unpack_domain_4D(pack_info(ind), loc, packed)
365    END DO
366  END SUBROUTINE unpack_4D
367
368  SUBROUTINE pack_domain_4D(info, loc, glob)
369    IMPLICIT NONE
370    TYPE(t_pack_info) :: info
371    REAL(rstd), DIMENSION(:,:,:) :: loc, glob
372    INTEGER :: jj,n,k,ij
373    DO jj=1, info%nseg
374       n = info%n(jj)-1
375       ij = info%ij(jj)
376       k = info%k(jj)
377       glob(k:k+n,:,:) = loc(ij:ij+n,:,:)
378    END DO
379  END SUBROUTINE pack_domain_4D
380
381  SUBROUTINE unpack_domain_4D(info, loc, glob)
382    IMPLICIT NONE
383    TYPE(t_pack_info) :: info
384    REAL(rstd), DIMENSION(:,:,:) :: loc, glob
385    INTEGER :: jj,n,k,ij
386    DO jj=1, info%nseg
387       n = info%n(jj)-1
388       ij = info%ij(jj)
389       k = info%k(jj)
390       loc(ij:ij+n,:,:) = glob(k:k+n,:,:)
391    END DO
392  END SUBROUTINE unpack_domain_4D
393
394END MODULE physics_interface_mod
Note: See TracBrowser for help on using the repository browser.