My Project
 All Classes Files Functions Variables Macros
gradiv2_p.F
Go to the documentation of this file.
1  SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
2 c
3 c P. Le Van
4 c
5 c **********************************************************
6 c ld
7 c calcul de (grad (div) ) du vect. v ....
8 c
9 c xcov et ycov etant les composant.covariantes de v
10 c **********************************************************
11 c xcont , ycont et ld sont des arguments d'entree pour le s-prog
12 c gdx et gdy sont des arguments de sortie pour le s-prog
13 c
14 c
15  USE parallel
16  USE times
17  USE write_field_p
18  USE mod_hallo
19  IMPLICIT NONE
20 c
21 #include "dimensions.h"
22 #include "paramet.h"
23 #include "comgeom.h"
24 #include "comdissipn.h"
25 c
26 c ........ variables en arguments ........
27 
28  INTEGER klevel
29  REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
30  REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm )
31  REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel )
32 c
33 c ........ variables locales .........
34 c
35  REAL,SAVE :: div(ip1jmp1,llm)
36  REAL :: tmp_div2(ip1jmp1,llm)
37  REAL signe, nugrads
38  INTEGER l,ij,iter,ld
39  INTEGER :: ijb,ije,jjb,jje
40  Type(request) :: request_dissip
41 
42 c ........................................................
43 c
44 c
45 c CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
46 c CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 )
47 
48  ijb=ij_begin
49  ije=ij_end
50 
51 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
52  DO l = 1, klevel
53  gdx(ijb:ije,l)=xcov(ijb:ije,l)
54  ENDDO
55 c$OMP END DO NOWAIT
56 
57  ijb=ij_begin
58  ije=ij_end
59  if(pole_sud) ije=ij_end-iip1
60 
61 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
62  DO l = 1, klevel
63  gdy(ijb:ije,l)=ycov(ijb:ije,l)
64  ENDDO
65 c$OMP END DO NOWAIT
66 
67 c$OMP BARRIER
68  call register_hallo(gdy,ip1jm,llm,1,0,0,1,request_dissip)
69  call sendrequest(request_dissip)
70 c$OMP BARRIER
71  call waitrequest(request_dissip)
72 c$OMP BARRIER
73 c
74 c
75  signe = (-1.)**ld
76  nugrads = signe * cdivu
77 c
78 
79 
80  CALL divergf_p( klevel, gdx, gdy , div )
81 c call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
82 
83  IF( ld.GT.1 ) THEN
84 c$OMP BARRIER
85  call register_hallo(div,ip1jmp1,llm,1,1,1,1,request_dissip)
86  call sendrequest(request_dissip)
87 c$OMP BARRIER
88  call waitrequest(request_dissip)
89 c$OMP BARRIER
90  CALL laplacien_p( klevel, div, div )
91 
92 c ...... Iteration de l'operateur laplacien_gam .......
93 c call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
94 
95  DO iter = 1, ld -2
96 c$OMP BARRIER
97  call register_hallo(div,ip1jmp1,llm,1,1,1,1,request_dissip)
98  call sendrequest(request_dissip)
99 c$OMP BARRIER
100  call waitrequest(request_dissip)
101 
102 c$OMP BARRIER
103 
104  CALL laplacien_gam( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
105  * unsapolnga1, unsapolsga1, div, div )
106  ENDDO
107 c call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
108  ENDIF
109 
110  jjb=jj_begin
111  jje=jj_end
112 
113  CALL filtreg_p( div ,jjb,jje, jjp1, klevel, 2, 1, .true., 1 )
114 c call exchange_Hallo(div,ip1jmp1,llm,0,1)
115 c$OMP BARRIER
116  call register_hallo(div,ip1jmp1,llm,1,1,1,1,request_dissip)
117  call sendrequest(request_dissip)
118 c$OMP BARRIER
119  call waitrequest(request_dissip)
120 
121 c$OMP BARRIER
122 
123 
124  CALL grad_p( klevel, div, gdx, gdy )
125 
126 c
127  ijb=ij_begin
128  ije=ij_end
129 
130 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
131  DO l = 1, klevel
132 
133  if (pole_sud) ije=ij_end
134  DO ij = ijb, ije
135  gdx_out( ij,l ) = gdx( ij,l ) * nugrads
136  ENDDO
137 
138  if (pole_sud) ije=ij_end-iip1
139  DO ij = ijb, ije
140  gdy_out( ij,l ) = gdy( ij,l ) * nugrads
141  ENDDO
142 
143  ENDDO
144 c$OMP END DO NOWAIT
145 c
146  RETURN
147  END