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ées 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 chmin, 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

    CALL minmax(imodmax, xxim, chmin, chmax)
    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

    CALL minmax(idatmax, xxd, chmin, chmax)
    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			! (Les abscisses sont exprimées 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
40			REAL x0, xim0, dx, dxm
41	guez	122	REAL chmin, chmax
42	guez	98
43			INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
44
45			!-----------------------------------------------------
46
47			idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
48			imodmax = size(rlonimod)
49
50	guez	122	! REDEFINITION DE L'ORIGINE DES ABSCISSES
51			! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE
52	guez	98	DO imod = 1, imodmax
53			xxim(imod) = rlonimod(imod)
54			ENDDO
55
56	guez	122	CALL minmax(imodmax, xxim, chmin, chmax)
57			IF(chmax < 6.50) THEN
58	guez	98	DO imod = 1, imodmax
59			xxim(imod) = xxim(imod) * 180./pi
60			ENDDO
61			ENDIF
62
63			xim0 = xxim(imodmax) - 360.
64
65			DO imod = 1, imodmax
66			xxim(imod) = xxim(imod) - xim0
67			ENDDO
68
69			idatmax1 = idatmax +1
70
71			DO idat = 1, idatmax
72			xxd(idat) = dlonid(idat)
73			ENDDO
74
75	guez	122	CALL minmax(idatmax, xxd, chmin, chmax)
76			IF(chmax < 6.50) THEN
77	guez	98	DO idat = 1, idatmax
78			xxd(idat) = xxd(idat) * 180./pi
79			ENDDO
80			ENDIF
81
82			DO idat = 1, idatmax
83	guez	122	xxd(idat) = AMOD(xxd(idat) - xim0, 360.)
84	guez	98	fdd(idat) = fdat (idat)
85			ENDDO
86
87			i = 2
88			DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
89			i = i + 1
90			ENDDO
91			IF (xxd(i) < xxd(i-1)) THEN
92			ichang = i
93	guez	122	! * reorganisation des longitudes entre 0. et 360. degres **
94	guez	98	nid = idatmax - ichang +1
95			DO i = 1, nid
96	guez	122	xchan (i) = xxd(i+ichang -1)
97			fdchan(i) = fdd(i+ichang -1)
98	guez	98	ENDDO
99			DO i=1, ichang -1
100			xchan (i+ nid) = xxd(i)
101			fdchan(i+nid) = fdd(i)
102			ENDDO
103			DO i =1, idatmax
104			xxd(i) = xchan(i)
105			fdd(i) = fdchan(i)
106			ENDDO
107			end IF
108
109	guez	122	! translation des champs de donnees par rapport
110			! a la nouvelle origine, avec redondance de la
111			! maille a cheval sur les bords
112	guez	98
113			id0 = 0
114			id1 = 0
115
116			DO idat = 1, idatmax
117	guez	122	IF (xxd(idatmax1- idat) < 360.) exit
118	guez	98	id1 = id1 + 1
119			ENDDO
120
121			DO idat = 1, idatmax
122	guez	122	IF (xxd(idat) > 0.) exit
123	guez	98	id0 = id0 + 1
124			END DO
125
126	guez	122	IF(id1 /= 0) then
127	guez	98	DO idat = 1, id1
128			xxid(idat) = xxd(idatmax - id1 + idat) - 360.
129			fxd (idat) = fdd(idatmax - id1 + idat)
130			END DO
131			DO idat = 1, idatmax - id1
132			xxid(idat + id1) = xxd(idat)
133			fxd (idat + id1) = fdd(idat)
134			END DO
135			end IF
136
137			IF(id0 /= 0) then
138			DO idat = 1, idatmax - id0
139			xxid(idat) = xxd(idat + id0)
140			fxd (idat) = fdd(idat + id0)
141			END DO
142
143			DO idat = 1, id0
144	guez	122	xxid (idatmax - id0 + idat) = xxd(idat) + 360.
145			fxd (idatmax - id0 + idat) = fdd(idat)
146	guez	98	END DO
147			else
148			DO idat = 1, idatmax
149	guez	122	xxid(idat) = xxd(idat)
150			fxd (idat) = fdd(idat)
151	guez	98	ENDDO
152			end IF
153			xxid(idatmax1) = xxid(1) + 360.
154			fxd (idatmax1) = fxd(1)
155
156	guez	122	! initialisation du champ du modele
157	guez	98
158			inter_barx(:) = 0.
159
160			! iteration
161
162	guez	122	x0 = xim0
163			dxm = 0.
164	guez	98	imod = 1
165			idat = 1
166
167			do while (imod <= imodmax)
168	guez	122	do while (xxim(imod) > xxid(idat))
169			dx = xxid(idat) - x0
170			dxm = dxm + dx
171	guez	98	inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
172	guez	122	x0 = xxid(idat)
173	guez	98	idat = idat + 1
174			end do
175	guez	122	IF (xxim(imod) < xxid(idat)) THEN
176			dx = xxim(imod) - x0
177			dxm = dxm + dx
178	guez	98	inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
179	guez	122	x0 = xxim(imod)
180			dxm = 0.
181	guez	98	imod = imod + 1
182			ELSE
183	guez	122	dx = xxim(imod) - x0
184			dxm = dxm + dx
185	guez	98	inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
186	guez	122	x0 = xxim(imod)
187			dxm = 0.
188	guez	98	imod = imod + 1
189			idat = idat + 1
190			END IF
191			end do
192
193			END function inter_barx
194
195			end module inter_barx_m