dyn3d/Inter_barxy/inter_barx.f

module inter_barx_m

  implicit none

contains

  function inter_barx(dlonid, fdat, rlonimod)

    ! From dyn3d/inter_barx.F, version 1.1.1.1 2004/05/19 12:53:06

    ! Authors: Robert Sadourny, P. Le Van

    ! INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
    ! VERSION UNIDIMENSIONNELLE, EN LONGITUDE .

    ! idat : indice du champ de donnees, de 1 a idatmax
    ! imod : indice du champ du modele, de 1 a imodmax
    ! fdat(idat) : champ de donnees (entrees)
    ! inter_barx(imod) : champ du modele (sorties)
    ! dlonid(idat): abscisses des interfaces des mailles donnees
    ! rlonimod(imod): abscisses des interfaces des mailles modele
    ! (L'indice 1 correspond a l'interface mailLE 1 / maille 2)
    ! (Les abscisses sont exprim\'ees en degres)

    use nr_util, only: assert_eq, pi

    REAL, intent(in):: dlonid(:)
    real, intent(in):: fdat(:)
    real, intent(in):: rlonimod(:)

    real inter_barx(size(rlonimod))

    ! Variables locales 

    INTEGER idatmax, imodmax
    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
    REAL fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1)
    REAL xxim(size(rlonimod))
    REAL x0, xim0, dx, dxm
    REAL chmax
    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1

    !-----------------------------------------------------

    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
    imodmax = size(rlonimod)

    ! REDEFINITION DE L'ORIGINE DES ABSCISSES
    ! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE
    DO imod = 1, imodmax
       xxim(imod) = rlonimod(imod)
    ENDDO

    chmax = maxval(xxim)
    IF(chmax < 6.50) THEN
       DO imod = 1, imodmax
          xxim(imod) = xxim(imod) * 180./pi
       ENDDO
    ENDIF

    xim0 = xxim(imodmax) - 360.

    DO imod = 1, imodmax
       xxim(imod) = xxim(imod) - xim0
    ENDDO

    idatmax1 = idatmax +1

    DO idat = 1, idatmax
       xxd(idat) = dlonid(idat)
    ENDDO

    chmax = maxval(xxd(:idatmax))
    IF(chmax < 6.50) THEN
       DO idat = 1, idatmax
          xxd(idat) = xxd(idat) * 180./pi
       ENDDO
    ENDIF

    DO idat = 1, idatmax
       xxd(idat) = AMOD(xxd(idat) - xim0, 360.)
       fdd(idat) = fdat (idat)
    ENDDO

    i = 2
    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
       i = i + 1
    ENDDO
    IF (xxd(i) < xxd(i-1)) THEN
       ichang = i
       ! *** reorganisation des longitudes entre 0. et 360. degres ****
       nid = idatmax - ichang +1
       DO i = 1, nid
          xchan (i) = xxd(i+ichang -1)
          fdchan(i) = fdd(i+ichang -1)
       ENDDO
       DO i=1, ichang -1
          xchan (i+ nid) = xxd(i)
          fdchan(i+nid) = fdd(i)
       ENDDO
       DO i =1, idatmax
          xxd(i) = xchan(i)
          fdd(i) = fdchan(i)
       ENDDO
    end IF

    ! translation des champs de donnees par rapport
    ! a la nouvelle origine, avec redondance de la
    ! maille a cheval sur les bords

    id0 = 0
    id1 = 0

    DO idat = 1, idatmax
       IF (xxd(idatmax1- idat) < 360.) exit
       id1 = id1 + 1
    ENDDO

    DO idat = 1, idatmax
       IF (xxd(idat) > 0.) exit
       id0 = id0 + 1
    END DO

    IF(id1 /= 0) then
       DO idat = 1, id1
          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
          fxd (idat) = fdd(idatmax - id1 + idat)
       END DO
       DO idat = 1, idatmax - id1
          xxid(idat + id1) = xxd(idat)
          fxd (idat + id1) = fdd(idat)
       END DO
    end IF

    IF(id0 /= 0) then
       DO idat = 1, idatmax - id0
          xxid(idat) = xxd(idat + id0)
          fxd (idat) = fdd(idat + id0)
       END DO

       DO idat = 1, id0
          xxid (idatmax - id0 + idat) = xxd(idat) + 360.
          fxd (idatmax - id0 + idat) = fdd(idat)
       END DO
    else
       DO idat = 1, idatmax
          xxid(idat) = xxd(idat)
          fxd (idat) = fdd(idat)
       ENDDO
    end IF
    xxid(idatmax1) = xxid(1) + 360.
    fxd (idatmax1) = fxd(1)

    ! initialisation du champ du modele

    inter_barx(:) = 0.

    ! iteration

    x0 = xim0
    dxm = 0.
    imod = 1
    idat = 1

    do while (imod <= imodmax)
       do while (xxim(imod) > xxid(idat))
          dx = xxid(idat) - x0
          dxm = dxm + dx
          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
          x0 = xxid(idat)
          idat = idat + 1
       end do
       IF (xxim(imod) < xxid(idat)) THEN
          dx = xxim(imod) - x0
          dxm = dxm + dx
          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
          x0 = xxim(imod)
          dxm = 0.
          imod = imod + 1
       ELSE
          dx = xxim(imod) - x0
          dxm = dxm + dx
          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
          x0 = xxim(imod)
          dxm = 0.
          imod = imod + 1
          idat = idat + 1
       END IF
    end do

  END function inter_barx

end module inter_barx_m
1	guez	98	module inter_barx_m
2
3			implicit none
4
5			contains
6
7			function inter_barx(dlonid, fdat, rlonimod)
8
9	guez	122	! From dyn3d/inter_barx.F, version 1.1.1.1 2004/05/19 12:53:06
10	guez	98
11	guez	122	! Authors: Robert Sadourny, P. Le Van
12	guez	98
13	guez	122	! INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
14			! VERSION UNIDIMENSIONNELLE, EN LONGITUDE .
15	guez	98
16	guez	122	! idat : indice du champ de donnees, de 1 a idatmax
17			! imod : indice du champ du modele, de 1 a imodmax
18			! fdat(idat) : champ de donnees (entrees)
19			! inter_barx(imod) : champ du modele (sorties)
20			! dlonid(idat): abscisses des interfaces des mailles donnees
21			! rlonimod(imod): abscisses des interfaces des mailles modele
22			! (L'indice 1 correspond a l'interface mailLE 1 / maille 2)
23	guez	208	! (Les abscisses sont exprim\'ees en degres)
24	guez	98
25	guez	122	use nr_util, only: assert_eq, pi
26	guez	98
27			REAL, intent(in):: dlonid(:)
28			real, intent(in):: fdat(:)
29			real, intent(in):: rlonimod(:)
30
31			real inter_barx(size(rlonimod))
32
33	guez	122	! Variables locales
34	guez	98
35			INTEGER idatmax, imodmax
36			REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
37	guez	122	REAL fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1)
38			REAL xxim(size(rlonimod))
39	guez	98	REAL x0, xim0, dx, dxm
40	guez	208	REAL chmax
41	guez	98	INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
42
43			!-----------------------------------------------------
44
45			idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
46			imodmax = size(rlonimod)
47
48	guez	122	! REDEFINITION DE L'ORIGINE DES ABSCISSES
49			! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE
50	guez	98	DO imod = 1, imodmax
51			xxim(imod) = rlonimod(imod)
52			ENDDO
53
54	guez	208	chmax = maxval(xxim)
55	guez	122	IF(chmax < 6.50) THEN
56	guez	98	DO imod = 1, imodmax
57			xxim(imod) = xxim(imod) * 180./pi
58			ENDDO
59			ENDIF
60
61			xim0 = xxim(imodmax) - 360.
62
63			DO imod = 1, imodmax
64			xxim(imod) = xxim(imod) - xim0
65			ENDDO
66
67			idatmax1 = idatmax +1
68
69			DO idat = 1, idatmax
70			xxd(idat) = dlonid(idat)
71			ENDDO
72
73	guez	208	chmax = maxval(xxd(:idatmax))
74	guez	122	IF(chmax < 6.50) THEN
75	guez	98	DO idat = 1, idatmax
76			xxd(idat) = xxd(idat) * 180./pi
77			ENDDO
78			ENDIF
79
80			DO idat = 1, idatmax
81	guez	122	xxd(idat) = AMOD(xxd(idat) - xim0, 360.)
82	guez	98	fdd(idat) = fdat (idat)
83			ENDDO
84
85			i = 2
86			DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
87			i = i + 1
88			ENDDO
89			IF (xxd(i) < xxd(i-1)) THEN
90			ichang = i
91	guez	122	! * reorganisation des longitudes entre 0. et 360. degres **
92	guez	98	nid = idatmax - ichang +1
93			DO i = 1, nid
94	guez	122	xchan (i) = xxd(i+ichang -1)
95			fdchan(i) = fdd(i+ichang -1)
96	guez	98	ENDDO
97			DO i=1, ichang -1
98			xchan (i+ nid) = xxd(i)
99			fdchan(i+nid) = fdd(i)
100			ENDDO
101			DO i =1, idatmax
102			xxd(i) = xchan(i)
103			fdd(i) = fdchan(i)
104			ENDDO
105			end IF
106
107	guez	122	! translation des champs de donnees par rapport
108			! a la nouvelle origine, avec redondance de la
109			! maille a cheval sur les bords
110	guez	98
111			id0 = 0
112			id1 = 0
113
114			DO idat = 1, idatmax
115	guez	122	IF (xxd(idatmax1- idat) < 360.) exit
116	guez	98	id1 = id1 + 1
117			ENDDO
118
119			DO idat = 1, idatmax
120	guez	122	IF (xxd(idat) > 0.) exit
121	guez	98	id0 = id0 + 1
122			END DO
123
124	guez	122	IF(id1 /= 0) then
125	guez	98	DO idat = 1, id1
126			xxid(idat) = xxd(idatmax - id1 + idat) - 360.
127			fxd (idat) = fdd(idatmax - id1 + idat)
128			END DO
129			DO idat = 1, idatmax - id1
130			xxid(idat + id1) = xxd(idat)
131			fxd (idat + id1) = fdd(idat)
132			END DO
133			end IF
134
135			IF(id0 /= 0) then
136			DO idat = 1, idatmax - id0
137			xxid(idat) = xxd(idat + id0)
138			fxd (idat) = fdd(idat + id0)
139			END DO
140
141			DO idat = 1, id0
142	guez	122	xxid (idatmax - id0 + idat) = xxd(idat) + 360.
143			fxd (idatmax - id0 + idat) = fdd(idat)
144	guez	98	END DO
145			else
146			DO idat = 1, idatmax
147	guez	122	xxid(idat) = xxd(idat)
148			fxd (idat) = fdd(idat)
149	guez	98	ENDDO
150			end IF
151			xxid(idatmax1) = xxid(1) + 360.
152			fxd (idatmax1) = fxd(1)
153
154	guez	122	! initialisation du champ du modele
155	guez	98
156			inter_barx(:) = 0.
157
158			! iteration
159
160	guez	122	x0 = xim0
161			dxm = 0.
162	guez	98	imod = 1
163			idat = 1
164
165			do while (imod <= imodmax)
166	guez	122	do while (xxim(imod) > xxid(idat))
167			dx = xxid(idat) - x0
168			dxm = dxm + dx
169	guez	98	inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
170	guez	122	x0 = xxid(idat)
171	guez	98	idat = idat + 1
172			end do
173	guez	122	IF (xxim(imod) < xxid(idat)) THEN
174			dx = xxim(imod) - x0
175			dxm = dxm + dx
176	guez	98	inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
177	guez	122	x0 = xxim(imod)
178			dxm = 0.
179	guez	98	imod = imod + 1
180			ELSE
181	guez	122	dx = xxim(imod) - x0
182			dxm = dxm + dx
183	guez	98	inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
184	guez	122	x0 = xxim(imod)
185			dxm = 0.
186	guez	98	imod = imod + 1
187			idat = idat + 1
188			END IF
189			end do
190
191			END function inter_barx
192
193			end module inter_barx_m