source: LMDZ6/trunk/libf/dyn3d_common/inter_barxy_m.f90 @ 5450

Last change on this file since 5450 was 5285, checked in by abarral, 2 months ago

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