source: LMDZ6/trunk/libf/dyn3dmem/nxgraro2_loc.F @ 4643

Last change on this file since 4643 was 4593, checked in by yann meurdesoif, 17 months ago

Replace #include (c preprocessor) by INCLUDE (fortran keyword)

in phylmd (except rrtm and ecrad) filtrez, dy3dmem and dyn3dcommon

Other directories will follow
YM

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 3.6 KB
Line 
1       SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out)
2c
3c      P.Le Van .
4c   ***********************************************************
5c                                 lr
6c      calcul de  ( nxgrad (rot) )   du vect. v  ....
7c
8c       xcov et ycov  etant les compos. covariantes de  v
9c   ***********************************************************
10c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
11c      grx   et  gry     sont des arguments de sortie pour le s-prog
12c
13c
14      USE write_Field_p
15      USE parallel_lmdz
16      USE times
17      USE mod_hallo
18      USE mod_filtreg_p
19      USE nxgraro2_mod
20      IMPLICIT NONE
21c
22      INCLUDE "dimensions.h"
23      INCLUDE "paramet.h"
24      INCLUDE "comdissipn.h"
25c
26c    ......  variables en arguments  .......
27c
28      INTEGER klevel
29      REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel )
30      REAL  grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel)
31c
32c    ......   variables locales     ........
33c
34      REAL  signe, nugradrs
35      INTEGER l,ij,iter,lr
36      Type(Request),SAVE :: Request_dissip
37!$OMP THREADPRIVATE(Request_dissip)
38c    ........................................................
39c
40      INTEGER :: ijb,ije,jjb,jje
41     
42c
43c
44      signe    = (-1.)**lr
45      nugradrs = signe * crot
46c
47c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
48c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
49 
50      ijb=ij_begin
51      ije=ij_end
52
53c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
54      DO    l = 1, klevel
55        grx(ijb:ije,l)=xcov(ijb:ije,l)
56      ENDDO
57c$OMP END DO NOWAIT
58
59c$OMP BARRIER
60       call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip)
61       call SendRequest(Request_dissip)
62c$OMP BARRIER
63       call WaitRequest(Request_dissip)
64c$OMP BARRIER
65
66      ijb=ij_begin
67      ije=ij_end
68      if(pole_sud) ije=ij_end-iip1
69
70c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
71      DO    l = 1, klevel
72        gry(ijb:ije,l)=ycov(ijb:ije,l)
73      ENDDO
74c$OMP END DO NOWAIT
75 
76c
77      CALL     rotatf_loc ( klevel, grx, gry, rot )
78c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
79
80c$OMP BARRIER
81       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
82       call SendRequest(Request_dissip)
83c$OMP BARRIER
84       call WaitRequest(Request_dissip)
85c$OMP BARRIER
86     
87      CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry      )
88c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
89c
90c    .....   Iteration de l'operateur laplacien_rotgam  .....
91c
92      DO  iter = 1, lr -2
93c$OMP BARRIER
94       call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip)
95       call SendRequest(Request_dissip)
96c$OMP BARRIER
97       call WaitRequest(Request_dissip)
98c$OMP BARRIER
99
100        CALL laplacien_rotgam_loc( klevel, rot, rot )
101      ENDDO
102     
103c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
104     
105c
106c
107      jjb=jj_begin
108      jje=jj_end
109      if (pole_sud) jje=jj_end-1
110       
111      CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm,
112     &                klevel, 2,1, .FALSE.,1)
113c$OMP BARRIER
114       call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip)
115       call SendRequest(Request_dissip)
116c$OMP BARRIER
117       call WaitRequest(Request_dissip)
118c$OMP BARRIER
119
120      CALL nxgrad_loc ( klevel, rot, grx, gry )
121
122c
123      ijb=ij_begin
124      ije=ij_end
125     
126c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
127      DO    l = 1, klevel
128       
129         if(pole_sud) ije=ij_end-iip1
130         DO  ij = ijb, ije
131          gry_out( ij,l ) = gry( ij,l ) * nugradrs
132         ENDDO
133       
134         if(pole_sud) ije=ij_end
135         DO  ij = ijb, ije
136          grx_out( ij,l ) = grx( ij,l ) * nugradrs
137         ENDDO
138     
139      ENDDO
140c$OMP END DO NOWAIT
141c
142      RETURN
143      END
Note: See TracBrowser for help on using the repository browser.