Context Navigation

extrapol.F @ 1356

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

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

tous les FLOAT() sont remplacés par des REAL()
tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

all FLOAT() instructions have been replaced by REAL() instructions
all STOP instructions in phylmd have been replaced by calls to abort_gcm
the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
$Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 5.0 KB

Line
1	!
2	! $Id: extrapol.F 1299 2010-01-20 14:27:21Z musat $
3	!
4	C
5	C
6	SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
7	. norsud, ldper, knbor, pwork)
8	IMPLICIT none
9	c
10	c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
11	c Fill up missed values by using the neighbor points
12	c
13	INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
14	INTEGER knbor ! minimum neighbor number (Input)
15	LOGICAL norsud ! True if field is from North to South (Input)
16	LOGICAL ldper ! True if take into account the periodicity (Input)
17	REAL pmask ! mask value (Input)
18	REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
19	REAL pwork(kxlon,kylat) ! working space
20	c
21	REAL zwmsk
22	INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
23	INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
24	REAL zmask(9)
25	C
26	C We search over the eight closest neighbors
27	C
28	C j+1 7 8 9
29	C j 4 5 6 Current point 5 --> (i,j)
30	C j-1 1 2 3
31	C i-1 i i+1
32	c
33	c
34	IF (norsud) THEN
35	DO j = 1, kylat
36	DO i = 1, kxlon
37	pwork(i,j) = pfild(i,kylat-j+1)
38	ENDDO
39	ENDDO
40	DO j = 1, kylat
41	DO i = 1, kxlon
42	pfild(i,j) = pwork(i,j)
43	ENDDO
44	ENDDO
45	ENDIF
46	c
47	incre = 0
48	c
49	DO j = 1, kylat
50	DO i = 1, kxlon
51	pwork(i,j) = pfild(i,j)
52	ENDDO
53	ENDDO
54	c
55	C* To avoid problems in floating point tests
56	zwmsk = pmask - 1.0
57	c
58	200 CONTINUE
59	incre = incre + 1
60	DO 99999 j = 1, kylat
61	DO 99999 i = 1, kxlon
62	IF (pfild(i,j).GT. zwmsk) THEN
63	pwork(i,j) = pfild(i,j)
64	inbor = 0
65	ideb = 1
66	ifin = 9
67	C
68	C* Fill up ix array
69	ix(1) = MAX (1,i-1)
70	ix(2) = i
71	ix(3) = MIN (kxlon,i+1)
72	ix(4) = MAX (1,i-1)
73	ix(5) = i
74	ix(6) = MIN (kxlon,i+1)
75	ix(7) = MAX (1,i-1)
76	ix(8) = i
77	ix(9) = MIN (kxlon,i+1)
78	C
79	C* Fill up iy array
80	jy(1) = MAX (1,j-1)
81	jy(2) = MAX (1,j-1)
82	jy(3) = MAX (1,j-1)
83	jy(4) = j
84	jy(5) = j
85	jy(6) = j
86	jy(7) = MIN (kylat,j+1)
87	jy(8) = MIN (kylat,j+1)
88	jy(9) = MIN (kylat,j+1)
89	C
90	C* Correct latitude bounds if southernmost or northernmost points
91	IF (j .EQ. 1) ideb = 4
92	IF (j .EQ. kylat) ifin = 6
93	C
94	C* Account for periodicity in longitude
95	C
96	IF (ldper) THEN
97	IF (i .EQ. kxlon) THEN
98	ix(3) = 1
99	ix(6) = 1
100	ix(9) = 1
101	ELSE IF (i .EQ. 1) THEN
102	ix(1) = kxlon
103	ix(4) = kxlon
104	ix(7) = kxlon
105	ENDIF
106	ELSE
107	IF (i .EQ. 1) THEN
108	ix(1) = i
109	ix(2) = i + 1
110	ix(3) = i
111	ix(4) = i + 1
112	ix(5) = i
113	ix(6) = i + 1
114	ENDIF
115	IF (i .EQ. kxlon) THEN
116	ix(1) = i -1
117	ix(2) = i
118	ix(3) = i - 1
119	ix(4) = i
120	ix(5) = i - 1
121	ix(6) = i
122	ENDIF
123	C
124	IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN
125	jy(1) = MAX (1,j-1)
126	jy(2) = MAX (1,j-1)
127	jy(3) = j
128	jy(4) = j
129	jy(5) = MIN (kylat,j+1)
130	jy(6) = MIN (kylat,j+1)
131	C
132	ideb = 1
133	ifin = 6
134	IF (j .EQ. 1) ideb = 3
135	IF (j .EQ. kylat) ifin = 4
136	ENDIF
137	ENDIF ! end for ldper test
138	C
139	C* Find unmasked neighbors
140	C
141	DO 230 k = ideb, ifin
142	zmask(k) = 0.
143	ilon = ix(k)
144	jlat = jy(k)
145	IF (pfild(ilon,jlat) .LT. zwmsk) THEN
146	zmask(k) = 1.
147	inbor = inbor + 1
148	ENDIF
149	230 CONTINUE
150	C
151	C* Not enough points around point P are unmasked; interpolation on P
152	C will be done in a future call to extrap.
153	C
154	IF (inbor .GE. knbor) THEN
155	pwork(i,j) = 0.
156	DO k = ideb, ifin
157	ilon = ix(k)
158	jlat = jy(k)
159	pwork(i,j) = pwork(i,j)
160	$ + pfild(ilon,jlat) * zmask(k)/ REAL(inbor)
161	ENDDO
162	ENDIF
163	C
164	ENDIF
165	99999 CONTINUE
166	C
167	C* 3. Writing back unmasked field in pfild
168	C ------------------------------------
169	C
170	C* pfild then contains:
171	C - Values which were not masked
172	C - Interpolated values from the inbor neighbors
173	C - Values which are not yet interpolated
174	C
175	idoit = 0
176	DO j = 1, kylat
177	DO i = 1, kxlon
178	IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1
179	pfild(i,j) = pwork(i,j)
180	ENDDO
181	ENDDO
182	c
183	IF (idoit .ne. 0) GOTO 200
184	ccc PRINT*, "Number of extrapolation steps incre =", incre
185	c
186	IF (norsud) THEN
187	DO j = 1, kylat
188	DO i = 1, kxlon
189	pwork(i,j) = pfild(i,kylat-j+1)
190	ENDDO
191	ENDDO
192	DO j = 1, kylat
193	DO i = 1, kxlon
194	pfild(i,j) = pwork(i,j)
195	ENDDO
196	ENDDO
197	ENDIF
198	c
199	RETURN
200	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format