My Project
 All Classes Files Functions Variables Macros
caldyn_p.F
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4 c
5 c
6 #undef DEBUG_IO
7 c#define DEBUG_IO
8 
9  SUBROUTINE caldyn_p
10  $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
11  $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
12  USE parallel
13  USE write_field_p
14 
15  IMPLICIT NONE
16 
17 c=======================================================================
18 c
19 c Auteur : P. Le Van
20 c
21 c Objet:
22 c ------
23 c
24 c Calcul des tendances dynamiques.
25 c
26 c Modif 04/93 F.Forget
27 c=======================================================================
28 
29 c-----------------------------------------------------------------------
30 c 0. Declarations:
31 c ----------------
32 
33 #include "dimensions.h"
34 #include "paramet.h"
35 #include "comconst.h"
36 #include "comvert.h"
37 #include "comgeom.h"
38 
39 c Arguments:
40 c ----------
41 
42  LOGICAL conser
43 
44  INTEGER itau
45  REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
46  REAL ps(ip1jmp1),phis(ip1jmp1)
47  REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm)
48  REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
49  REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
50  REAL dv(ip1jm,llm),du(ip1jmp1,llm)
51  REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
52  REAL w(ip1jmp1,llm)
53  REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
54  REAL time
55 
56 c Local:
57 c ------
58 
59  REAL,SAVE :: ang(ip1jmp1,llm)
60  REAL,SAVE :: p(ip1jmp1,llmp1)
61  REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm)
62  REAL,SAVE :: psexbarxy(ip1jm)
63  REAL,SAVE :: vorpot(ip1jm,llm)
64  REAL,SAVE :: ecin(ip1jmp1,llm)
65  REAL,SAVE :: bern(ip1jmp1,llm)
66  REAL,SAVE :: massebxy(ip1jm,llm)
67  REAL,SAVE :: convm(ip1jmp1,llm)
68  INTEGER ij,l,ijb,ije,ierr
69 
70 c-----------------------------------------------------------------------
71 c Calcul des tendances dynamiques:
72 c --------------------------------
73  CALL covcont_p( llm , ucov , vcov , ucont, vcont )
74  CALL pression_p( ip1jmp1, ap , bp , ps , p )
75 cym CALL psextbar ( ps , psexbarxy )
76 c$OMP BARRIER
77  CALL massdair_p( p , masse )
78  CALL massbar_p( masse, massebx , masseby )
79  call massbarxy_p( masse, massebxy )
80  CALL flumass_p( massebx, masseby , vcont, ucont ,pbaru, pbarv )
81  CALL dteta1_p( teta , pbaru , pbarv, dteta )
82  CALL convmas1_p( pbaru, pbarv , convm )
83 c$OMP BARRIER
84  CALL convmas2_p( convm )
85 c$OMP BARRIER
86 #ifdef DEBUG_IO
87 c$OMP BARRIER
88 c$OMP MASTER
89  call writefield_p('ucont',reshape(ucont,(/iip1,jmp1,llm/)))
90  call writefield_p('vcont',reshape(vcont,(/iip1,jjm,llm/)))
91  call writefield_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
92  call writefield_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
93  call writefield_p('massebx',reshape(massebx,(/iip1,jmp1,llm/)))
94  call writefield_p('masseby',reshape(masseby,(/iip1,jjm,llm/)))
95  call writefield_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/)))
96  call writefield_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
97  call writefield_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
98  call writefield_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
99  call writefield_p('convm',reshape(convm,(/iip1,jmp1,llm/)))
100 c$OMP END MASTER
101 c$OMP BARRIER
102 #endif
103 
104 c$OMP BARRIER
105 c$OMP MASTER
106  ijb=ij_begin
107  ije=ij_end
108 
109  DO ij =ijb, ije
110  dp( ij ) = convm( ij,1 ) / airesurg( ij )
111  ENDDO
112 c$OMP END MASTER
113 c$OMP BARRIER
114 c$OMP FLUSH
115  CALL vitvert_p( convm , w )
116  CALL tourpot_p( vcov , ucov , massebxy , vorpot )
117  CALL dudv1_p( vorpot , pbaru , pbarv , du , dv )
118 
119 #ifdef DEBUG_IO
120 c$OMP BARRIER
121 c$OMP MASTER
122  call writefield_p('w',reshape(w,(/iip1,jmp1,llm/)))
123  call writefield_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/)))
124  call writefield_p('du',reshape(du,(/iip1,jmp1,llm/)))
125  call writefield_p('dv',reshape(dv,(/iip1,jjm,llm/)))
126 c$OMP END MASTER
127 c$OMP BARRIER
128 #endif
129  CALL enercin_p( vcov , ucov , vcont , ucont , ecin )
130  CALL bernoui_p( ip1jmp1, llm , phi , ecin , bern )
131  CALL dudv2_p( teta , pkf , bern , du , dv )
132 
133 #ifdef DEBUG_IO
134 c$OMP BARRIER
135 c$OMP MASTER
136  call writefield_p('ecin',reshape(ecin,(/iip1,jmp1,llm/)))
137  call writefield_p('bern',reshape(bern,(/iip1,jmp1,llm/)))
138  call writefield_p('du',reshape(du,(/iip1,jmp1,llm/)))
139  call writefield_p('dv',reshape(dv,(/iip1,jjm,llm/)))
140  call writefield_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
141 c$OMP END MASTER
142 c$OMP BARRIER
143 #endif
144 
145  ijb=ij_begin-iip1
146  ije=ij_end+iip1
147 
148  if (pole_nord) ijb=ij_begin
149  if (pole_sud) ije=ij_end
150 
151 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
152  DO l=1,llm
153  DO ij=ijb,ije
154  ang(ij,l) = ucov(ij,l) + constang(ij)
155  ENDDO
156  ENDDO
157 c$OMP END DO
158 
159  CALL advect_new_p(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
160 
161 C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
162 C probablement. Observe sur le code compile avec pgf90 3.0-1
163  ijb=ij_begin
164  ije=ij_end
165  if (pole_sud) ije=ij_end-iip1
166 
167 c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
168  DO l = 1, llm
169  DO ij = ijb, ije, iip1
170  IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN
171 c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
172 c , ' dans caldyn'
173 c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
174  dv(ij+iim,l) = dv(ij,l)
175  endif
176  enddo
177  enddo
178 c$OMP END DO NOWAIT
179 c-----------------------------------------------------------------------
180 c Sorties eventuelles des variables de controle:
181 c ----------------------------------------------
182 
183  IF( conser ) THEN
184 c ym ---> exige communication collective ( aussi dans advect)
185  CALL sortvarc
186  $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
187 
188  ENDIF
189 
190  RETURN
191  END