My Project
 All Classes Files Functions Variables Macros
nxgraro2_p.F
Go to the documentation of this file.
1  SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out )
2 c
3 c p.le van .
4 c ***********************************************************
5 c lr
6 c calcul de( nxgrad(rot) ) du vect. v ....
7 c
8 c xcov et ycov etant les compos. covariantes de v
9 c ***********************************************************
10 c xcov , ycov et lr sont des arguments d
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 
71 
72 
73 
74 
75 
76 
77 'entree pour le s-progc grx et gry sont des arguments de sortie pour le s-progcc USE write_Field_p USE parallel USE times USE mod_hallo IMPLICIT NONEc#include "dimensions.h"#include "paramet.h"#include "comdissipn.h"cc ...... variables en arguments .......c INTEGER klevel REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel )cc ...... variables locales ........c REAL,SAVE :: rot(ip1jm,llm) REAL signe, nugradrs INTEGER l,ij,iter,lr Type(Request) :: Request_dissipc ........................................................c INTEGER :: ijb,ije,jjb,jje cc signe = (-1.)**lr nugradrs = signe * crotcc CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )c CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) ijb=ij_begin ije=ij_endc$OMP DO SCHEDULE(STATIC,OMP_CHUNK) DO l = 1, klevel grx(ijb:ije,l)=xcov(ijb:ije,l) ENDDOc$OMP END DO NOWAITc$OMP BARRIER call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip) call SendRequest(Request_dissip)c$OMP BARRIER call WaitRequest(Request_dissip)c$OMP BARRIER ijb=ij_begin ije=ij_end if(pole_sud) ije=ij_end-iip1c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) DO l = 1, klevel gry(ijb:ije,l)=ycov(ijb:ije,l) ENDDOc$OMP END DO NOWAIT c CALL rotatf_p ( klevel, grx, gry, rot )c call write_field3d_p('rot1
78 
79 
80 
81 
82 
83 
84 
85 
86 
87 ',reshape(rot,(/iip1,jjm,llm/)))c$OMP BARRIER call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) call SendRequest(Request_dissip)c$OMP BARRIER call WaitRequest(Request_dissip)c$OMP BARRIER CALL laplacien_rot_p ( klevel, rot, rot,grx,gry )c call write_field3d_p('rot2
88 
89 ',reshape(rot,(/iip1,jjm,llm/)))cc ..... Iteration de l'operateur laplacien_rotgam .....
90 c
91  DO iter = 1, lr -2
92 c$omp barrier
93  call register_hallo(rot,ip1jm,llm,1,1,1,1,request_dissip)
94  call sendrequest(request_dissip)
95 c$omp barrier
96  call waitrequest(request_dissip)
97 c$omp barrier
98 
99  CALL laplacien_rotgam_p( klevel, rot, rot )
100  ENDDO
101 
102 c call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
103 
104 c
105 c
106  jjb=jj_begin
107  jje=jj_end
108  if (pole_sud) jje=jj_end-1
109 
110  CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .false.,1)
111 c$omp barrier
112  call register_hallo(rot,ip1jm,llm,1,0,0,1,request_dissip)
113  call sendrequest(request_dissip)
114 c$omp barrier
115  call waitrequest(request_dissip)
116 c$omp barrier
117 
118  CALL nxgrad_p( klevel, rot, grx, gry )
119 
120 c
121  ijb=ij_begin
122  ije=ij_end
123 
124 c$omp DO schedule(static,omp_chunk)
125  DO l = 1, klevel
126 
127  if(pole_sud) ije=ij_end-iip1
128  DO ij = ijb, ije
129  gry_out( ij,l ) = gry( ij,l ) * nugradrs
130  ENDDO
131 
132  if(pole_sud) ije=ij_end
133  DO ij = ijb, ije
134  grx_out( ij,l ) = grx( ij,l ) * nugradrs
135  ENDDO
136 
137  ENDDO
138 c$omp END DO nowait
139 c
140  RETURN
141  END