source: LMDZ5/branches/LMDZ5-DOFOCO/libf/dyn3dpar/inter_barxy_m.F90 @ 5371

Last change on this file since 5371 was 1342, checked in by Laurent Fairhead, 15 years ago

Use generic rather than specific names for intrinsic procedures.

Utilisations des noms génériques pour les procédures intrinsèques
File size: 12.2 KB
Line 
1!
2! $Id$
3!
4module inter_barxy_m
5
6  ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ
7
8  implicit none
9
10  private
11  public inter_barxy
12
13contains
14
15  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
16
17    use assert_eq_m, only: assert_eq
18    use assert_m, only: assert
19
20    include "dimensions.h"
21    ! (for "iim", "jjm")
22
23    include "paramet.h"
24    ! (for other included files)
25
26    include "comgeom2.h"
27    ! (for "aire", "apoln", "apols")
28
29    REAL, intent(in):: dlonid(:)
30    ! (longitude from input file, in rad, from -pi to pi)
31
32    REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:)
33
34    REAL, intent(in):: rlatimod(:)
35    ! (latitude angle, in degrees or rad, in strictly decreasing order)
36
37    real, intent(out):: champint(:, :)
38    ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les
39    ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U)
40    ! Si taille de la seconde dim = jjm, on veut interpoler sur les
41    ! jjm latitudes rlatv du modele (latitudes de V)
42
43    ! Variables local to the procedure:
44
45    REAL champy(iim, size(champ, 2))
46    integer j, i, jnterfd, jmods
47
48    REAL yjmod(size(champint, 2))
49    ! (angle, in degrees, in strictly increasing order)
50
51    REAL   yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order
52    LOGICAL decrois ! "dlatid" is in decreasing order
53
54    !-----------------------------------
55
56    jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), &
57         "inter_barxy jnterfd")
58    jmods = size(champint, 2)
59    call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)")
60    call assert((/size(rlonimod), size(champint, 1)/) == iim, &
61         "inter_barxy iim")
62    call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods')
63    call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)")
64
65    ! Check decreasing order for "rlatimod":
66    DO i = 2, jjm
67       IF (rlatimod(i) >= rlatimod(i-1)) stop &
68            '"inter_barxy": "rlatimod" should be strictly decreasing'
69    ENDDO
70
71    yjmod(:jjm) = ord_coordm(rlatimod)
72    IF (jmods == jjm + 1) THEN
73       IF (90. - yjmod(jjm) < 0.01) stop &
74            '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.'
75    ELSE
76       ! jmods = jjm
77       IF (ABS(yjmod(jjm) - 90.) > 0.01) stop &
78            '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.'
79    ENDIF
80
81    if (jmods == jjm + 1) yjmod(jjm + 1) = 90.
82
83    DO j = 1, jnterfd + 1
84       champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod)
85    ENDDO
86
87    CALL ord_coord(dlatid, yjdat, decrois)
88    IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1)
89    DO i = 1, iim
90       champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod)
91    ENDDO
92    champint(:, :) = champint(:, jmods:1:-1)
93
94    IF (jmods == jjm + 1) THEN
95       ! Valeurs uniques aux poles
96       champint(:, 1) = SUM(aire(:iim,  1) * champint(:, 1)) / apoln
97       champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) &
98            * champint(:, jjm + 1)) / apols
99    ENDIF
100
101  END SUBROUTINE inter_barxy
102
103  !******************************
104
105  function inter_barx(dlonid, fdat, rlonimod)
106
107    !        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
108    !            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
109
110    !     idat : indice du champ de donnees, de 1 a idatmax
111    !     imod : indice du champ du modele,  de 1 a  imodmax
112    !     fdat(idat) : champ de donnees (entrees)
113    !     inter_barx(imod) : champ du modele (sorties)
114    !     dlonid(idat): abscisses des interfaces des mailles donnees
115    !     rlonimod(imod): abscisses des interfaces des mailles modele
116    !      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
117    !      ( Les abscisses sont exprimees en degres)
118
119    use assert_eq_m, only: assert_eq
120
121    IMPLICIT NONE
122
123    REAL, intent(in):: dlonid(:)
124    real, intent(in):: fdat(:)
125    real, intent(in):: rlonimod(:)
126
127    real inter_barx(size(rlonimod))
128
129    !    ...  Variables locales ...
130
131    INTEGER idatmax, imodmax
132    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
133    REAL  fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1)
134    REAL  xxim(size(rlonimod))
135
136    REAL x0, xim0, dx, dxm
137    REAL chmin, chmax, pi
138
139    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
140
141    !-----------------------------------------------------
142
143    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
144    imodmax = size(rlonimod)
145
146    pi = 2. * ASIN(1.)
147
148    !   REDEFINITION DE L'ORIGINE DES ABSCISSES
149    !    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE 
150    DO imod = 1, imodmax
151       xxim(imod) = rlonimod(imod)
152    ENDDO
153
154    CALL minmax( imodmax, xxim, chmin, chmax)
155    IF( chmax.LT.6.50 )   THEN
156       DO imod = 1, imodmax
157          xxim(imod) = xxim(imod) * 180./pi
158       ENDDO
159    ENDIF
160
161    xim0 = xxim(imodmax) - 360.
162
163    DO imod = 1, imodmax
164       xxim(imod) = xxim(imod) - xim0
165    ENDDO
166
167    idatmax1 = idatmax +1
168
169    DO idat = 1, idatmax
170       xxd(idat) = dlonid(idat)
171    ENDDO
172
173    CALL minmax( idatmax, xxd, chmin, chmax)
174    IF( chmax.LT.6.50 )  THEN
175       DO idat = 1, idatmax
176          xxd(idat) = xxd(idat) * 180./pi
177       ENDDO
178    ENDIF
179
180    DO idat = 1, idatmax
181       xxd(idat) = MOD( xxd(idat) - xim0, 360. )
182       fdd(idat) = fdat (idat)
183    ENDDO
184
185    i = 2
186    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
187       i = i + 1
188    ENDDO
189    IF (xxd(i) < xxd(i-1)) THEN
190       ichang = i
191       !  ***  reorganisation  des longitudes entre 0. et 360. degres ****
192       nid = idatmax - ichang +1
193       DO i = 1, nid
194          xchan (i) = xxd(i+ichang -1 )
195          fdchan(i) = fdd(i+ichang -1 )
196       ENDDO
197       DO i=1, ichang -1
198          xchan (i+ nid) = xxd(i)
199          fdchan(i+nid) = fdd(i)
200       ENDDO
201       DO i =1, idatmax
202          xxd(i) = xchan(i)
203          fdd(i) = fdchan(i)
204       ENDDO
205    end IF
206
207    !    translation des champs de donnees par rapport
208    !    a la nouvelle origine, avec redondance de la
209    !       maille a cheval sur les bords
210
211    id0 = 0
212    id1 = 0
213
214    DO idat = 1, idatmax
215       IF ( xxd( idatmax1- idat ).LT.360.) exit
216       id1 = id1 + 1
217    ENDDO
218
219    DO idat = 1, idatmax
220       IF (xxd(idat).GT.0.) exit
221       id0 = id0 + 1
222    END DO
223
224    IF( id1 /= 0 ) then
225       DO idat = 1, id1
226          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
227          fxd (idat) = fdd(idatmax - id1 + idat)     
228       END DO
229       DO idat = 1, idatmax - id1
230          xxid(idat + id1) = xxd(idat)
231          fxd (idat + id1) = fdd(idat)
232       END DO
233    end IF
234
235    IF(id0 /= 0) then
236       DO idat = 1, idatmax - id0
237          xxid(idat) = xxd(idat + id0)
238          fxd (idat) = fdd(idat + id0)
239       END DO
240
241       DO idat = 1, id0
242          xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
243          fxd  (idatmax - id0 + idat) =  fdd(idat)   
244       END DO
245    else
246       DO idat = 1, idatmax
247          xxid(idat)  = xxd(idat)
248          fxd (idat)  = fdd(idat)
249       ENDDO
250    end IF
251    xxid(idatmax1) = xxid(1) + 360.
252    fxd (idatmax1) = fxd(1)
253
254    !   initialisation du champ du modele
255
256    inter_barx(:) = 0.
257
258    ! iteration
259
260    x0   = xim0
261    dxm  = 0.
262    imod = 1
263    idat = 1
264
265    do while (imod <= imodmax)
266       do while (xxim(imod).GT.xxid(idat))
267          dx   = xxid(idat) - x0
268          dxm  = dxm + dx
269          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
270          x0   = xxid(idat)
271          idat = idat + 1
272       end do
273       IF (xxim(imod).LT.xxid(idat)) THEN
274          dx   = xxim(imod) - x0
275          dxm  = dxm + dx
276          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
277          x0   = xxim(imod)
278          dxm  = 0.
279          imod = imod + 1
280       ELSE
281          dx   = xxim(imod) - x0
282          dxm  = dxm + dx
283          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
284          x0   = xxim(imod)
285          dxm  = 0.
286          imod = imod + 1
287          idat = idat + 1
288       END IF
289    end do
290
291  END function inter_barx
292
293  !******************************
294
295  function inter_bary(yjdat, fdat, yjmod)
296
297    ! Interpolation barycentrique basée sur les aires.
298    ! Version unidimensionnelle, en latitude.
299    ! L'indice 1 correspond à l'interface maille 1 -- maille 2.
300
301    use assert_m, only: assert
302
303    IMPLICIT NONE
304
305    REAL, intent(in):: yjdat(:)
306    ! (angles, ordonnées des interfaces des mailles des données, in
307    ! degrees, in increasing order)
308
309    REAL, intent(in):: fdat(:) ! champ de données
310
311    REAL, intent(in):: yjmod(:)
312    ! (ordonnées des interfaces des mailles du modèle)
313    ! (in degrees, in strictly increasing order)
314
315    REAL inter_bary(size(yjmod)) ! champ du modèle
316
317    ! Variables local to the procedure:
318
319    REAL y0, dy, dym
320    INTEGER jdat ! indice du champ de données
321    integer jmod ! indice du champ du modèle
322
323    !------------------------------------
324
325    call assert(size(yjdat) == size(fdat), "inter_bary")
326
327    ! Initialisation des variables
328    inter_bary(:) = 0.
329    y0    = -90.
330    dym   = 0.
331    jmod  = 1
332    jdat  = 1
333
334    do while (jmod <= size(yjmod))
335       do while (yjmod(jmod) > yjdat(jdat))
336          dy         = yjdat(jdat) - y0
337          dym        = dym + dy
338          inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat)
339          y0         = yjdat(jdat)
340          jdat       = jdat + 1
341       end do
342       IF (yjmod(jmod) < yjdat(jdat)) THEN
343          dy         = yjmod(jmod) - y0
344          dym        = dym + dy
345          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
346          y0         = yjmod(jmod)
347          dym        = 0.
348          jmod       = jmod + 1
349       ELSE
350          ! {yjmod(jmod) == yjdat(jdat)}
351          dy         = yjmod(jmod) - y0
352          dym        = dym + dy
353          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
354          y0         = yjmod(jmod)
355          dym        = 0.
356          jmod       = jmod + 1
357          jdat       = jdat + 1
358       END IF
359    end do
360    ! Le test de fin suppose que l'interface 0 est commune aux deux
361    ! grilles "yjdat" et "yjmod".
362
363  END function inter_bary
364
365  !******************************
366
367  SUBROUTINE ord_coord(xi, xo, decrois)
368
369    ! This procedure receives an array of latitudes.
370    ! It converts them to degrees if they are in radians.
371    ! If the input latitudes are in decreasing order, the procedure
372    ! reverses their order.
373    ! Finally, the procedure adds 90° as the last value of the array.
374
375    use assert_eq_m, only: assert_eq
376
377    IMPLICIT NONE
378
379    include "comconst.h"
380    ! (for "pi")
381
382    REAL, intent(in):: xi(:)
383    ! (latitude, in degrees or radians, in increasing or decreasing order)
384    ! ("xi" should contain latitudes from pole to pole.
385    ! "xi" should contain the latitudes of the boundaries of grid
386    ! cells, not the centers of grid cells.
387    ! So the extreme values should not be 90° and -90°.)
388
389    REAL, intent(out):: xo(:) ! angles in degrees
390    LOGICAL, intent(out):: decrois
391
392    ! Variables  local to the procedure:
393    INTEGER nmax, i
394
395    !--------------------
396
397    nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord")
398
399    ! Check monotonicity:
400    decrois = xi(2) < xi(1)
401    DO i = 3, nmax
402       IF (decrois .neqv. xi(i) < xi(i-1)) stop &
403            '"ord_coord":  latitudes are not monotonic'
404    ENDDO
405
406    IF (abs(xi(1)) < pi) then
407       ! "xi" contains latitudes in radians
408       xo(:nmax) = xi(:) * 180. / pi
409    else
410       ! "xi" contains latitudes in degrees
411       xo(:nmax) = xi(:)
412    end IF
413
414    IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN
415       print *, "ord_coord"
416       PRINT *, '"xi" should contain the latitudes of the boundaries of ' &
417            // 'grid cells, not the centers of grid cells.'
418       STOP
419    ENDIF
420
421    IF (decrois) xo(:nmax) = xo(nmax:1:- 1)
422    xo(nmax + 1) = 90.
423
424  END SUBROUTINE ord_coord
425
426  !***********************************
427
428  function ord_coordm(xi)
429
430    ! This procedure converts to degrees, if necessary, and inverts the
431    ! order.
432
433    IMPLICIT NONE
434
435    include "comconst.h"
436    ! (for "pi")
437
438    REAL, intent(in):: xi(:) ! angle, in rad or degrees
439    REAL ord_coordm(size(xi)) ! angle, in degrees
440
441    !-----------------------------
442
443    IF (xi(1) < 6.5) THEN
444       ! "xi" is in rad
445       ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi
446    else
447       ! "xi" is in degrees
448       ord_coordm(:) = xi(size(xi):1:-1)
449    ENDIF
450
451  END function ord_coordm
452
453end module inter_barxy_m
Note: See TracBrowser for help on using the repository browser.