1 | SUBROUTINE grid_noro1(imdep, jmdep, xdata, ydata, entree, |
---|
2 | . imar, jmar, x, y, zmea,zstd,zsig,zgam,zthe) |
---|
3 | c======================================================================= |
---|
4 | c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) |
---|
5 | c |
---|
6 | c Calcul des parametres de l'orographie sous-maille necessaires |
---|
7 | c au nouveau shema de representation des montagnes meso-echelles |
---|
8 | c dans le modele. Les points sont mis sur une grille rectangulaire |
---|
9 | c pseudo-physique. Typiquement, il y a iim+1 latitudes incluant |
---|
10 | c le pole nord et le pole sud. Il y a jjm+1 longitudes, y compris |
---|
11 | c aux poles. Aux poles les champs peuvent ont une valeurs repetee |
---|
12 | c jjm+1 fois..... La valeur du champs en jjm+1 (jmar) est celle |
---|
13 | c en j=1. |
---|
14 | c Les parametres a,b,c,d representent les limites de la region |
---|
15 | c de point de grille correspondant a un point decrit precedemment. |
---|
16 | c Les moyennes sur ces regions des valeurs calculees a partir de |
---|
17 | c l'USN, sont ponderees par un poids, fonction de la surface |
---|
18 | c occuppe par ces donnees a l'interieure de la grille du modele. |
---|
19 | c Dans la plupart des cas ce poid est le rapport entre la surface |
---|
20 | c de la region de point de grille USN et la surface de la region |
---|
21 | c de point de grille du modele. |
---|
22 | c |
---|
23 | c |
---|
24 | c (c) |
---|
25 | c ----d----- |
---|
26 | c | . . . .| |
---|
27 | c | | |
---|
28 | c (b)a . * . .b(a) |
---|
29 | c | | |
---|
30 | c | . . . .| |
---|
31 | c ----c----- |
---|
32 | c (d) |
---|
33 | C======================================================================= |
---|
34 | c INPUT: |
---|
35 | c imdep, jmdep: dimensions X et Y pour depart |
---|
36 | c xdata, ydata: coordonnees X et Y pour depart |
---|
37 | c entree: champ d'entree a transformer |
---|
38 | c dans ce programme, on assume que les donnees sont les altitudes |
---|
39 | c de l'USNavy: imdep=iusn=2160, jmdep=jusn=1080. |
---|
40 | c OUTPUT: |
---|
41 | c imar, jmar: dimensions X et Y d'arrivee |
---|
42 | c x, y: coordonnees X et Y d'arrivee |
---|
43 | c les champs de sorties sont sur une grille physique: |
---|
44 | c zmea: orographie moyenne |
---|
45 | c zstd: deviation standard de l'orographie sous-maille |
---|
46 | c zsig: pente de l'orographie sous-maille |
---|
47 | c zgam: anisotropy de l'orographie sous maille |
---|
48 | c zthe: orientation de l'axe oriente dans la direction |
---|
49 | c de plus grande pente de l'orographie sous maille |
---|
50 | C======================================================================= |
---|
51 | c IMPLICIT INTEGER (I,J) |
---|
52 | c IMPLICIT REAL(X,Z) |
---|
53 | |
---|
54 | USE comconst_mod, ONLY: rad |
---|
55 | |
---|
56 | implicit none |
---|
57 | integer iusn,jusn,iext |
---|
58 | parameter(iusn=360,jusn=180,iext=40) |
---|
59 | c!-*- include 'param1' |
---|
60 | c!-*- include 'comcstfi.h' |
---|
61 | #include "dimensions.h" |
---|
62 | c!-*- |
---|
63 | c!-*- parameter(iim=cols,jjm=rows) |
---|
64 | REAL xusn(iusn+2*iext),yusn(jusn+2) |
---|
65 | REAL zusn(iusn+2*iext,jusn+2),zusnfi(iusn+2*iext,jusn+2) |
---|
66 | |
---|
67 | c modif declarations pour implicit none |
---|
68 | real zmeanor,zmeasud,zstdnor,zstdsud,zsignor |
---|
69 | real zsigsud,zweinor,zweisud |
---|
70 | real xk,xl,xm,xw,xp,xq |
---|
71 | real zmaxmea,zmaxstd,zmaxsig,zmaxgam,zmaxthe,zminthe |
---|
72 | real zbordnor,zbordsud,zbordest,zbordoue,xpi |
---|
73 | real zdeltax,zdeltay,zlenx,zleny,weighx,weighy,xincr |
---|
74 | integer i,j,ii,jj,ideltax,ihalph |
---|
75 | |
---|
76 | INTEGER imdep, jmdep |
---|
77 | REAL xdata(imdep),ydata(jmdep) |
---|
78 | REAL entree(imdep,jmdep) |
---|
79 | c |
---|
80 | INTEGER imar, jmar |
---|
81 | |
---|
82 | REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) |
---|
83 | REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) |
---|
84 | REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) |
---|
85 | REAL zxtzyusn(iusn+2*iext,jusn+2) |
---|
86 | REAL weight(iim+1,jjm+1) |
---|
87 | REAL x(imar+1),y(jmar) |
---|
88 | REAL zmea(imar+1,jmar),zstd(imar+1,jmar) |
---|
89 | REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) |
---|
90 | c |
---|
91 | REAL a(2200),b(2200),c(1100),d(1100) |
---|
92 | c |
---|
93 | c quelques constantes: |
---|
94 | c |
---|
95 | print *,' parametres de l orographie a l echelle sous maille' |
---|
96 | print*,'rad =',rad |
---|
97 | print*,'Long et lat entree' |
---|
98 | print*,(x(i),i=1,imar+1) |
---|
99 | print*,(y(j),j=1,jmar) |
---|
100 | print*,'Long et lat donnees' |
---|
101 | print*,(xdata(i),i=1,imdep) |
---|
102 | print*,(ydata(j),j=1,jmdep) |
---|
103 | |
---|
104 | xpi=acos(-1.) |
---|
105 | zdeltay=2.*xpi/float(jusn)*rad |
---|
106 | c |
---|
107 | c quelques tests de dimensions: |
---|
108 | c |
---|
109 | IF (imar.GT.2200 .OR. jmar.GT.1100) THEN |
---|
110 | PRINT*, 'imar ou jmar trop grand', imar, jmar |
---|
111 | CALL ABORT |
---|
112 | ENDIF |
---|
113 | |
---|
114 | IF(imdep.ne.iusn.or.jmdep.ne.jusn)then |
---|
115 | print *,' imdep ou jmdep mal dimensionnes:',imdep,jmdep |
---|
116 | call abort |
---|
117 | ENDIF |
---|
118 | |
---|
119 | IF(imar+1.gt.iim+1.or.jmar.gt.jjm+1)THEN |
---|
120 | print *,' imar ou jmar mal dimensionnes:',imar,jmar |
---|
121 | call abort |
---|
122 | ENDIF |
---|
123 | c |
---|
124 | C Extension de la base de donnee de l'USN pour faciliter |
---|
125 | C les calculs ulterieurs: |
---|
126 | c |
---|
127 | DO j=1,jusn |
---|
128 | yusn(j+1)=ydata(j) |
---|
129 | DO i=1,iusn |
---|
130 | zusn(i+iext,j+1)=entree(i,j) |
---|
131 | xusn(i+iext)=xdata(i) |
---|
132 | ENDDO |
---|
133 | DO i=1,iext |
---|
134 | zusn(i,j+1)=entree(iusn-iext+i,j) |
---|
135 | xusn(i)=xdata(iusn-iext+i)-2.*xpi |
---|
136 | zusn(iusn+iext+i,j+1)=entree(i,j) |
---|
137 | xusn(iusn+iext+i)=xdata(i)+2.*xpi |
---|
138 | ENDDO |
---|
139 | ENDDO |
---|
140 | |
---|
141 | yusn(1)=ydata(1)+(ydata(1)-ydata(2)) |
---|
142 | yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) |
---|
143 | DO i=1,iusn/2+iext |
---|
144 | zusn(i,1)=zusn(i+iusn/2,2) |
---|
145 | zusn(i+iusn/2+iext,1)=zusn(i,2) |
---|
146 | zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) |
---|
147 | zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) |
---|
148 | ENDDO |
---|
149 | c |
---|
150 | c Calcul d'une orographie filtree aux hautes latitudes |
---|
151 | c pour permettre des calculs plus isotropiques sur la pente |
---|
152 | c des montagnes |
---|
153 | c |
---|
154 | DO i=1,IUSN+2*iext |
---|
155 | DO J=1,JUSN+2 |
---|
156 | zusnfi(i,j)=0.0 |
---|
157 | ENDDO |
---|
158 | ENDDO |
---|
159 | |
---|
160 | DO j=1,jusn |
---|
161 | ideltax=1./cos(yusn(j+1)) |
---|
162 | ideltax=min(iusn/2-1,ideltax) |
---|
163 | IF(MOD(IDELTAX,2).EQ.0)THEN |
---|
164 | IDELTAX=IDELTAX+1 |
---|
165 | ENDIF |
---|
166 | IHALPH=(IDELTAX-1)/2 |
---|
167 | c print *,' ideltax=',ideltax |
---|
168 | IF(ideltax.eq.1)THEN |
---|
169 | DO i=1,iusn |
---|
170 | zusnfi(i+iext,j+1)=entree(i,j) |
---|
171 | ENDDO |
---|
172 | ELSE |
---|
173 | DO i=1,ihalph |
---|
174 | DO ii=1,i+ihalph |
---|
175 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) |
---|
176 | ENDDO |
---|
177 | DO ii=ihalph-i,0,-1 |
---|
178 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(iusn-ii,j) |
---|
179 | ENDDO |
---|
180 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) |
---|
181 | ENDDO |
---|
182 | DO i=iusn-ihalph+1,iusn |
---|
183 | DO ii = i-ihalph,iusn |
---|
184 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) |
---|
185 | ENDDO |
---|
186 | DO ii = 1,ihalph+i-iusn |
---|
187 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) |
---|
188 | ENDDO |
---|
189 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) |
---|
190 | ENDDO |
---|
191 | DO i=ihalph+1,iusn-ihalph |
---|
192 | DO ii=-ihalph,ihalph |
---|
193 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(i+ii,j) |
---|
194 | ENDDO |
---|
195 | zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) |
---|
196 | ENDDO |
---|
197 | ENDIF |
---|
198 | DO i=1,iext |
---|
199 | zusnfi(i,j+1)=zusnfi(iusn-iext+i,j+1) |
---|
200 | zusnfi(i+iusn+iext,j+1)=zusnfi(i,j+1) |
---|
201 | ENDDO |
---|
202 | ENDDO |
---|
203 | c |
---|
204 | c Calculer les limites des zones des nouveaux points |
---|
205 | c |
---|
206 | a(1) = x(1) - (x(2)-x(1))/2.0 |
---|
207 | b(1) = (x(1)+x(2))/2.0 |
---|
208 | DO i = 2, imar-1 |
---|
209 | a(i) = b(i-1) |
---|
210 | b(i) = (x(i)+x(i+1))/2.0 |
---|
211 | ENDDO |
---|
212 | a(imar) = b(imar-1) |
---|
213 | b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 |
---|
214 | |
---|
215 | c(1) = y(1) - (y(2)-y(1))/2.0 |
---|
216 | d(1) = (y(1)+y(2))/2.0 |
---|
217 | DO j = 2, jmar-1 |
---|
218 | c(j) = d(j-1) |
---|
219 | d(j) = (y(j)+y(j+1))/2.0 |
---|
220 | ENDDO |
---|
221 | c(jmar) = d(jmar-1) |
---|
222 | d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 |
---|
223 | c |
---|
224 | c quelques initialisations: |
---|
225 | print*,'OKM1' |
---|
226 | c |
---|
227 | DO i = 1, imar |
---|
228 | DO j = 1, jmar |
---|
229 | weight(i,j) = 0.0 |
---|
230 | zxtzx(i,j) = 0.0 |
---|
231 | zytzy(i,j) = 0.0 |
---|
232 | zxtzy(i,j) = 0.0 |
---|
233 | ztz(i,j) = 0.0 |
---|
234 | zmea(i,j) = 0.0 |
---|
235 | zstd(i,j)=0.0 |
---|
236 | ENDDO |
---|
237 | ENDDO |
---|
238 | c |
---|
239 | c calculs des correlations de pentes sur la grille de l'USN. |
---|
240 | c |
---|
241 | DO j = 2,jusn+1 |
---|
242 | DO i = 1, iusn+2*iext |
---|
243 | zytzyusn(i,j)=0.0 |
---|
244 | zxtzxusn(i,j)=0.0 |
---|
245 | zxtzyusn(i,j)=0.0 |
---|
246 | ENDDO |
---|
247 | ENDDO |
---|
248 | |
---|
249 | |
---|
250 | DO j = 2,jusn+1 |
---|
251 | zdeltax=zdeltay*cos(yusn(j)) |
---|
252 | DO i = 2, iusn+2*iext-1 |
---|
253 | zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 |
---|
254 | zxtzxusn(i,j)=(zusnfi(i+1,j)-zusnfi(i-1,j))**2/zdeltax**2 |
---|
255 | zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay |
---|
256 | * *(zusnfi(i+1,j)-zusnfi(i-1,j))/zdeltax |
---|
257 | ENDDO |
---|
258 | |
---|
259 | ENDDO |
---|
260 | |
---|
261 | |
---|
262 | |
---|
263 | print*,'OK0' |
---|
264 | c |
---|
265 | c sommations des differentes quantites definies precedemment |
---|
266 | c sur une grille du modele. |
---|
267 | c |
---|
268 | zleny=xpi/float(jusn)*rad |
---|
269 | xincr=xpi/2./float(jusn) |
---|
270 | DO ii = 1, imar |
---|
271 | DO jj = 1, jmar |
---|
272 | c PRINT *,' iteration ii jj:',ii,jj |
---|
273 | DO j = 2,jusn+1 |
---|
274 | c DO j = 3,jusn |
---|
275 | zlenx=zleny*cos(yusn(j)) |
---|
276 | zdeltax=zdeltay*cos(yusn(j)) |
---|
277 | zbordnor=(c(jj)-yusn(j)+xincr)*rad |
---|
278 | zbordsud=(yusn(j)-d(jj)+xincr)*rad |
---|
279 | weighy=amax1(0., |
---|
280 | * amin1(zbordnor,zbordsud,zleny)) |
---|
281 | IF(weighy.ne.0)THEN |
---|
282 | DO i = 2, iusn+2*iext-1 |
---|
283 | zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) |
---|
284 | zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) |
---|
285 | weighx=amax1(0., |
---|
286 | * amin1(zbordest,zbordoue,zlenx)) |
---|
287 | IF(weighx.ne.0)THEN |
---|
288 | weight(ii,jj)=weight(ii,jj)+weighx*weighy |
---|
289 | zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy |
---|
290 | zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy |
---|
291 | zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy |
---|
292 | ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy |
---|
293 | zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy |
---|
294 | ENDIF |
---|
295 | ENDDO |
---|
296 | ENDIF |
---|
297 | ENDDO |
---|
298 | ENDDO |
---|
299 | ENDDO |
---|
300 | c |
---|
301 | c calculs des differents parametres necessaires au programme |
---|
302 | c de parametrisation de l'orographie a l'echelle moyenne: |
---|
303 | c |
---|
304 | zmaxmea=0. |
---|
305 | zmaxstd=0. |
---|
306 | zmaxsig=0. |
---|
307 | zmaxgam=0. |
---|
308 | zmaxthe=0. |
---|
309 | zminthe=0. |
---|
310 | c print 100,' ' |
---|
311 | c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') |
---|
312 | print*,'OK1' |
---|
313 | DO ii = 1, imar |
---|
314 | DO jj = 1, jmar |
---|
315 | c print*,'ok0' |
---|
316 | IF (weight(ii,jj) .NE. 0.0) THEN |
---|
317 | c Orography moyenne: |
---|
318 | c print*,'ok1' |
---|
319 | zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) |
---|
320 | zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) |
---|
321 | zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) |
---|
322 | zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) |
---|
323 | ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) |
---|
324 | c print*,'ok2' |
---|
325 | c Deviation standard: |
---|
326 | zstd(ii,jj)=sqrt(amax1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) |
---|
327 | c Coefficients K, L et M: |
---|
328 | xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. |
---|
329 | xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. |
---|
330 | xm=zxtzy(ii,jj) |
---|
331 | xp=xk-sqrt(xl**2+xm**2) |
---|
332 | xq=xk+sqrt(xl**2+xm**2) |
---|
333 | xw=1.e-8 |
---|
334 | if(xp.le.xw) xp=0. |
---|
335 | if(xq.le.xw) xq=xw |
---|
336 | if(abs(xm).le.xw) xm=xw*sign(1.,xm) |
---|
337 | c print*,'ok3' |
---|
338 | c pente: |
---|
339 | zsig(ii,jj)=sqrt(xq) |
---|
340 | c zsig(ii,jj)=sqrt(2.*xk) |
---|
341 | c isotropy: |
---|
342 | zgam(ii,jj)=xp/xq |
---|
343 | c angle theta: |
---|
344 | zthe(ii,jj)=57.29577951*atan2(xm,xl)/2. |
---|
345 | |
---|
346 | c print 101,ii,jj, |
---|
347 | c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), |
---|
348 | c * zthe(ii,jj) |
---|
349 | c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) |
---|
350 | c print*,'ok4' |
---|
351 | ELSE |
---|
352 | c PRINT*, 'probleme,ii,jj=', ii,jj |
---|
353 | c print*,'ok1b' |
---|
354 | ENDIF |
---|
355 | zmaxmea=amax1(zmea(ii,jj),zmaxmea) |
---|
356 | c print*,'oka' |
---|
357 | zmaxstd=amax1(zstd(ii,jj),zmaxstd) |
---|
358 | c print*,'okb' |
---|
359 | zmaxsig=amax1(zsig(ii,jj),zmaxsig) |
---|
360 | c print*,'okc' |
---|
361 | zmaxgam=amax1(zgam(ii,jj),zmaxgam) |
---|
362 | c print*,'okd' |
---|
363 | zmaxthe=amax1(zthe(ii,jj),zmaxthe) |
---|
364 | c print*,'oke' |
---|
365 | zminthe=amin1(zthe(ii,jj),zminthe) |
---|
366 | c print*,'ok5' |
---|
367 | ENDDO |
---|
368 | ENDDO |
---|
369 | |
---|
370 | print *,' MEAN ORO:',zmaxmea |
---|
371 | print *,' ST. DEV.:',zmaxstd |
---|
372 | print *,' PENTE:',zmaxsig |
---|
373 | print *,' ANISOTROP:',zmaxgam |
---|
374 | print *,' ANGLE:',zminthe,zmaxthe |
---|
375 | |
---|
376 | C |
---|
377 | c On passe ce donnees sur la grille dite physique....(?) |
---|
378 | c On met gamma et theta a 1. et 0. aux poles ou ces quantites |
---|
379 | c n'ont pas vraiment de sens |
---|
380 | c |
---|
381 | DO jj=1,jmar |
---|
382 | zmea(imar+1,jj)=zmea(1,jj) |
---|
383 | zstd(imar+1,jj)=zstd(1,jj) |
---|
384 | zsig(imar+1,jj)=zsig(1,jj) |
---|
385 | zgam(imar+1,jj)=zgam(1,jj) |
---|
386 | zthe(imar+1,jj)=zthe(1,jj) |
---|
387 | ENDDO |
---|
388 | |
---|
389 | |
---|
390 | zmeanor=0.0 |
---|
391 | zmeasud=0.0 |
---|
392 | zstdnor=0.0 |
---|
393 | zstdsud=0.0 |
---|
394 | zsignor=0.0 |
---|
395 | zsigsud=0.0 |
---|
396 | zweinor=0.0 |
---|
397 | zweisud=0.0 |
---|
398 | |
---|
399 | DO ii=1,imar |
---|
400 | zweinor=zweinor+ weight(ii, 1) |
---|
401 | zweisud=zweisud+ weight(ii,jmar) |
---|
402 | zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) |
---|
403 | zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) |
---|
404 | zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) |
---|
405 | zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) |
---|
406 | zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) |
---|
407 | zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) |
---|
408 | ENDDO |
---|
409 | |
---|
410 | DO ii=1,imar+1 |
---|
411 | zmea(ii, 1)=zmeanor/zweinor |
---|
412 | zmea(ii,jmar)=zmeasud/zweisud |
---|
413 | zstd(ii, 1)=zstdnor/zweinor |
---|
414 | zstd(ii,jmar)=zstdsud/zweisud |
---|
415 | zsig(ii, 1)=zsignor/zweinor |
---|
416 | zsig(ii,jmar)=zsigsud/zweisud |
---|
417 | zgam(ii, 1)=1. |
---|
418 | zgam(ii,jmar)=1. |
---|
419 | zthe(ii, 1)=0. |
---|
420 | zthe(ii,jmar)=0. |
---|
421 | ENDDO |
---|
422 | |
---|
423 | |
---|
424 | RETURN |
---|
425 | END |
---|