source: LMDZ6/branches/DYNAMICO-conv/libf/dyn3dpar/nxgraro2_p.F

Last change on this file was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

  • 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
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.6 KB
Line 
1       SUBROUTINE nxgraro2_p (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      IMPLICIT NONE
19c
20#include "dimensions.h"
21#include "paramet.h"
22#include "comdissipn.h"
23c
24c    ......  variables en arguments  .......
25c
26      INTEGER klevel
27      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
28      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
29      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
30c
31c    ......   variables locales     ........
32c
33      REAL,SAVE :: rot(ip1jm,llm)
34      REAL  signe, nugradrs
35      INTEGER l,ij,iter,lr
36      Type(Request) :: Request_dissip
37c    ........................................................
38c
39      INTEGER :: ijb,ije,jjb,jje
40     
41c
42c
43      signe    = (-1.)**lr
44      nugradrs = signe * crot
45c
46c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
47c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
48 
49      ijb=ij_begin
50      ije=ij_end
51
52c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
53      DO    l = 1, klevel
54        grx(ijb:ije,l)=xcov(ijb:ije,l)
55      ENDDO
56c$OMP END DO NOWAIT
57
58c$OMP BARRIER
59       call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip)
60       call SendRequest(Request_dissip)
61c$OMP BARRIER
62       call WaitRequest(Request_dissip)
63c$OMP BARRIER
64
65      ijb=ij_begin
66      ije=ij_end
67      if(pole_sud) ije=ij_end-iip1
68
69c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
70      DO    l = 1, klevel
71        gry(ijb:ije,l)=ycov(ijb:ije,l)
72      ENDDO
73c$OMP END DO NOWAIT
74 
75c
76      CALL     rotatf_p     ( klevel, grx, gry, rot )
77c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
78
79c$OMP BARRIER
80       call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip)
81       call SendRequest(Request_dissip)
82c$OMP BARRIER
83       call WaitRequest(Request_dissip)
84c$OMP BARRIER
85     
86      CALL laplacien_rot_p ( klevel, rot, rot,grx,gry      )
87c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
88c
89c    .....   Iteration de l'operateur laplacien_rotgam  .....
90c
91      DO  iter = 1, lr -2
92c$OMP BARRIER
93       call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip)
94       call SendRequest(Request_dissip)
95c$OMP BARRIER
96       call WaitRequest(Request_dissip)
97c$OMP BARRIER
98
99        CALL laplacien_rotgam_p ( klevel, rot, rot )
100      ENDDO
101     
102c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
103     
104c
105c
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)
111c$OMP BARRIER
112       call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip)
113       call SendRequest(Request_dissip)
114c$OMP BARRIER
115       call WaitRequest(Request_dissip)
116c$OMP BARRIER
117
118      CALL nxgrad_p ( klevel, rot, grx, gry )
119
120c
121      ijb=ij_begin
122      ije=ij_end
123     
124c$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
138c$OMP END DO NOWAIT
139c
140      RETURN
141      END
Note: See TracBrowser for help on using the repository browser.