source: LMDZ5/branches/testing/libf/dyn3dmem/nxgrarot_p.F @ 1915

Last change on this file since 1915 was 1910, checked in by Laurent Fairhead, 11 years ago

Merged trunk changes r1860:1909 into testing branch

  • 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: 2.6 KB
Line 
1      SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out )
2c   ***********************************************************
3c
4c    Auteur :  P.Le Van 
5c
6c                                 lr
7c      calcul de  ( nXgrad (rot) )   du vect. v  ....
8c
9c       xcov et ycov  etant les compos. covariantes de  v
10c   ***********************************************************
11c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
12c      grx   et  gry     sont des arguments de sortie pour le s-prog
13c
14c
15      USE parallel_lmdz
16      USE times
17      USE write_field_p
18      IMPLICIT NONE
19c
20c
21#include "dimensions.h"
22#include "paramet.h"
23#include "comdissipn.h"
24#include "logic.h"
25c
26      INTEGER klevel
27      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
28      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
29      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
30
31c
32      REAL,SAVE :: rot(ip1jm,llm)
33
34      INTEGER l,ij,iter,lr
35c
36      INTEGER ijb,ije,jjb,jje
37c
38c
39c      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
40c      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
41c
42      ijb=ij_begin
43      ije=ij_end
44c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
45      DO l = 1, klevel
46        grx(ijb:ije,l)=xcov(ijb:ije,l)
47      ENDDO
48c$OMP END DO NOWAIT     
49
50      if(pole_sud) ije=ij_end-iip1
51c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
52      DO l = 1, klevel
53        gry(ijb:ije,l)=ycov(ijb:ije,l)
54      ENDDO
55c$OMP END DO NOWAIT
56     
57      DO 10 iter = 1,lr
58c$OMP BARRIER
59c$OMP MASTER
60      call suspend_timer(timer_dissip)
61      call exchange_Hallo(grx,ip1jmp1,llm,0,1)
62      call resume_timer(timer_dissip)
63c$OMP END MASTER
64c$OMP BARRIER
65
66      CALL  rotat_p (klevel,grx, gry, rot )
67c      call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/)))
68     
69      jjb=jj_begin
70      jje=jj_end
71      if (pole_sud) jje=jj_end-1
72      CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2)
73
74c$OMP BARRIER
75c$OMP MASTER
76      call suspend_timer(timer_dissip)
77      call exchange_Hallo(rot,ip1jm,llm,1,0)
78      call resume_timer(timer_dissip)
79c$OMP END MASTER
80c$OMP BARRIER
81     
82      CALL nxgrad_p (klevel,rot, grx, gry )
83c
84c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
85      DO 5  l = 1, klevel
86      if(pole_sud) ije=ij_end-iip1
87      DO 2 ij = ijb, ije
88      gry_out( ij,l ) = - gry( ij,l ) * crot
89   2  CONTINUE
90      if(pole_sud) ije=ij_end
91      DO 3 ij = ijb, ije
92      grx_out( ij,l ) = - grx( ij,l ) * crot
93   3  CONTINUE
94   5  CONTINUE
95c$OMP END DO NOWAIT
96c      call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/)))
97c      call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/)))
98c      stop
99  10  CONTINUE
100      RETURN
101      END
Note: See TracBrowser for help on using the repository browser.