Home

Context Navigation

source: palm/trunk/SOURCE/surface_coupler.f90 @ 1418

Last change on this file since 1418 was 1418, checked in by fricke, 10 years ago
Bugfixes concerning grid stretching for the ocean and calculation of the salinity flux in routine surface_coupler
Property svn:keywords set to `Id`
File size: 21.5 KB

Line
1	SUBROUTINE surface_coupler
2
3	!--------------------------------------------------------------------------------!
4	! This file is part of PALM.
5	!
6	! PALM is free software: you can redistribute it and/or modify it under the terms
7	! of the GNU General Public License as published by the Free Software Foundation,
8	! either version 3 of the License, or (at your option) any later version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 1997-2014 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	! Bugfix: For caluclation of the salinity flux at the sea surface,
23	! the given value for salinity must be in percent and not in psu
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: surface_coupler.f90 1418 2014-06-06 13:05:08Z fricke $
28	!
29	! 1353 2014-04-08 15:21:23Z heinze
30	! REAL constants provided with KIND-attribute
31	!
32	! 1324 2014-03-21 09:13:16Z suehring
33	! Bugfix: ONLY statement for module pegrid removed
34	!
35	! 1322 2014-03-20 16:38:49Z raasch
36	! REAL constants defined as wp-kind
37	!
38	! 1320 2014-03-20 08:40:49Z raasch
39	! ONLY-attribute added to USE-statements,
40	! kind-parameters added to all INTEGER and REAL declaration statements,
41	! kinds are defined in new module kinds,
42	! old module precision_kind is removed,
43	! revision history before 2012 removed,
44	! comment fields (!:) to be used for variable explanations added to
45	! all variable declaration statements
46	!
47	! 1318 2014-03-17 13:35:16Z raasch
48	! module interfaces removed
49	!
50	! 1092 2013-02-02 11:24:22Z raasch
51	! unused variables removed
52	!
53	! 1036 2012-10-22 13:43:42Z raasch
54	! code put under GPL (PALM 3.9)
55	!
56	! 880 2012-04-13 06:28:59Z raasch
57	! Bugfix: preprocessor statements for parallel execution added
58	!
59	! 109 2007-08-28 15:26:47Z letzel
60	! Initial revision
61	!
62	! Description:
63	! ------------
64	! Data exchange at the interface between coupled models
65	!------------------------------------------------------------------------------!
66
67	USE arrays_3d, &
68	ONLY: pt, shf, qsws, qswst_remote, rho, sa, saswst, total_2d_a, &
69	total_2d_o, tswst, u, usws, uswst, v, vsws, vswst
70
71	USE control_parameters, &
72	ONLY: coupling_mode, coupling_mode_remote, coupling_topology, &
73	humidity, humidity_remote, message_string, terminate_coupled, &
74	terminate_coupled_remote, time_since_reference_point
75
76	USE cpulog, &
77	ONLY: cpu_log, log_point
78
79	USE indices, &
80	ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, nx_a, nx_o, ny, nyn, nyng, nys, &
81	nysg, ny_a, ny_o, nzt
82
83	USE kinds
84
85	USE pegrid
86
87	IMPLICIT NONE
88
89	REAL(wp) :: time_since_reference_point_rem !:
90	REAL(wp) :: total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !:
91
92	#if defined( __parallel )
93
94	CALL cpu_log( log_point(39), 'surface_coupler', 'start' )
95
96
97
98	!
99	!-- In case of model termination initiated by the remote model
100	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
101	!-- The rest of the coupler must then be skipped because it would cause an MPI
102	!-- intercomminucation hang.
103	!-- If necessary, the coupler will be called at the beginning of the next
104	!-- restart run.
105
106	IF ( coupling_topology == 0 ) THEN
107	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, target_id, &
108	0, &
109	terminate_coupled_remote, 1, MPI_INTEGER, target_id, &
110	0, comm_inter, status, ierr )
111	ELSE
112	IF ( myid == 0) THEN
113	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
114	target_id, 0, &
115	terminate_coupled_remote, 1, MPI_INTEGER, &
116	target_id, 0, &
117	comm_inter, status, ierr )
118	ENDIF
119	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
120	ierr )
121
122	ALLOCATE( total_2d_a(-nbgp:ny_a+nbgp,-nbgp:nx_a+nbgp), &
123	total_2d_o(-nbgp:ny_o+nbgp,-nbgp:nx_o+nbgp) )
124
125	ENDIF
126
127	IF ( terminate_coupled_remote > 0 ) THEN
128	WRITE( message_string, * ) 'remote model "', &
129	TRIM( coupling_mode_remote ), &
130	'" terminated', &
131	'&with terminate_coupled_remote = ', &
132	terminate_coupled_remote, &
133	'&local model "', TRIM( coupling_mode ), &
134	'" has', &
135	'&terminate_coupled = ', &
136	terminate_coupled
137	CALL message( 'surface_coupler', 'PA0310', 1, 2, 0, 6, 0 )
138	RETURN
139	ENDIF
140
141
142	!
143	!-- Exchange the current simulated time between the models,
144	!-- currently just for total_2ding
145	IF ( coupling_topology == 0 ) THEN
146
147	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, 11, &
148	comm_inter, ierr )
149	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, target_id, &
150	11, comm_inter, status, ierr )
151	ELSE
152
153	IF ( myid == 0 ) THEN
154
155	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
156	11, comm_inter, ierr )
157	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
158	target_id, 11, comm_inter, status, ierr )
159
160	ENDIF
161
162	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
163	ierr )
164
165	ENDIF
166
167	!
168	!-- Exchange the interface data
169	IF ( coupling_mode == 'atmosphere_to_ocean' ) THEN
170
171	!
172	!-- Horizontal grid size and number of processors is equal in ocean and
173	!-- atmosphere
174	IF ( coupling_topology == 0 ) THEN
175
176	!
177	!-- Send heat flux at bottom surface to the ocean
178	CALL MPI_SEND( shf(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
179	comm_inter, ierr )
180	!
181	!-- Send humidity flux at bottom surface to the ocean
182	IF ( humidity ) THEN
183	CALL MPI_SEND( qsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 13, &
184	comm_inter, ierr )
185	ENDIF
186	!
187	!-- Receive temperature at the bottom surface from the ocean
188	CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14, &
189	comm_inter, status, ierr )
190	!
191	!-- Send the momentum flux (u) at bottom surface to the ocean
192	CALL MPI_SEND( usws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
193	comm_inter, ierr )
194	!
195	!-- Send the momentum flux (v) at bottom surface to the ocean
196	CALL MPI_SEND( vsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
197	comm_inter, ierr )
198	!
199	!-- Receive u at the bottom surface from the ocean
200	CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17, &
201	comm_inter, status, ierr )
202	!
203	!-- Receive v at the bottom surface from the ocean
204	CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18, &
205	comm_inter, status, ierr )
206	!
207	!-- Horizontal grid size or number of processors differs between
208	!-- ocean and atmosphere
209	ELSE
210
211	!
212	!-- Send heat flux at bottom surface to the ocean
213	total_2d_a = 0.0_wp
214	total_2d = 0.0_wp
215	total_2d(nys:nyn,nxl:nxr) = shf(nys:nyn,nxl:nxr)
216
217	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
218	comm2d, ierr )
219	CALL interpolate_to_ocean( 12 )
220	!
221	!-- Send humidity flux at bottom surface to the ocean
222	IF ( humidity ) THEN
223	total_2d_a = 0.0_wp
224	total_2d = 0.0_wp
225	total_2d(nys:nyn,nxl:nxr) = qsws(nys:nyn,nxl:nxr)
226
227	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, &
228	0, comm2d, ierr )
229	CALL interpolate_to_ocean( 13 )
230	ENDIF
231	!
232	!-- Receive temperature at the bottom surface from the ocean
233	IF ( myid == 0 ) THEN
234	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
235	target_id, 14, comm_inter, status, ierr )
236	ENDIF
237	CALL MPI_BARRIER( comm2d, ierr )
238	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
239	ierr )
240	pt(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
241	!
242	!-- Send momentum flux (u) at bottom surface to the ocean
243	total_2d_a = 0.0_wp
244	total_2d = 0.0_wp
245	total_2d(nys:nyn,nxl:nxr) = usws(nys:nyn,nxl:nxr)
246	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
247	comm2d, ierr )
248	CALL interpolate_to_ocean( 15 )
249	!
250	!-- Send momentum flux (v) at bottom surface to the ocean
251	total_2d_a = 0.0_wp
252	total_2d = 0.0_wp
253	total_2d(nys:nyn,nxl:nxr) = vsws(nys:nyn,nxl:nxr)
254	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
255	comm2d, ierr )
256	CALL interpolate_to_ocean( 16 )
257	!
258	!-- Receive u at the bottom surface from the ocean
259	IF ( myid == 0 ) THEN
260	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
261	target_id, 17, comm_inter, status, ierr )
262	ENDIF
263	CALL MPI_BARRIER( comm2d, ierr )
264	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
265	ierr )
266	u(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
267	!
268	!-- Receive v at the bottom surface from the ocean
269	IF ( myid == 0 ) THEN
270	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
271	target_id, 18, comm_inter, status, ierr )
272	ENDIF
273	CALL MPI_BARRIER( comm2d, ierr )
274	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
275	ierr )
276	v(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
277
278	ENDIF
279
280	ELSEIF ( coupling_mode == 'ocean_to_atmosphere' ) THEN
281
282	!
283	!-- Horizontal grid size and number of processors is equal
284	!-- in ocean and atmosphere
285	IF ( coupling_topology == 0 ) THEN
286	!
287	!-- Receive heat flux at the sea surface (top) from the atmosphere
288	CALL MPI_RECV( tswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
289	comm_inter, status, ierr )
290	!
291	!-- Receive humidity flux from the atmosphere (bottom)
292	!-- and add it to the heat flux at the sea surface (top)...
293	IF ( humidity_remote ) THEN
294	CALL MPI_RECV( qswst_remote(nysg,nxlg), ngp_xy, MPI_REAL, &
295	target_id, 13, comm_inter, status, ierr )
296	ENDIF
297	!
298	!-- Send sea surface temperature to the atmosphere model
299	CALL MPI_SEND( pt(nzt,nysg,nxlg), 1, type_xy, target_id, 14, &
300	comm_inter, ierr )
301	!
302	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
303	CALL MPI_RECV( uswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
304	comm_inter, status, ierr )
305	!
306	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
307	CALL MPI_RECV( vswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
308	comm_inter, status, ierr )
309	!
310	!-- Send u to the atmosphere
311	CALL MPI_SEND( u(nzt,nysg,nxlg), 1, type_xy, target_id, 17, &
312	comm_inter, ierr )
313	!
314	!-- Send v to the atmosphere
315	CALL MPI_SEND( v(nzt,nysg,nxlg), 1, type_xy, target_id, 18, &
316	comm_inter, ierr )
317	!
318	!-- Horizontal gridsize or number of processors differs between
319	!-- ocean and atmosphere
320	ELSE
321	!
322	!-- Receive heat flux at the sea surface (top) from the atmosphere
323	IF ( myid == 0 ) THEN
324	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
325	target_id, 12, comm_inter, status, ierr )
326	ENDIF
327	CALL MPI_BARRIER( comm2d, ierr )
328	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
329	ierr )
330	tswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
331	!
332	!-- Receive humidity flux at the sea surface (top) from the atmosphere
333	IF ( humidity_remote ) THEN
334	IF ( myid == 0 ) THEN
335	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
336	target_id, 13, comm_inter, status, ierr )
337	ENDIF
338	CALL MPI_BARRIER( comm2d, ierr )
339	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
340	comm2d, ierr)
341	qswst_remote(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
342	ENDIF
343	!
344	!-- Send surface temperature to atmosphere
345	total_2d_o = 0.0_wp
346	total_2d = 0.0_wp
347	total_2d(nys:nyn,nxl:nxr) = pt(nzt,nys:nyn,nxl:nxr)
348
349	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
350	comm2d, ierr)
351	CALL interpolate_to_atmos( 14 )
352	!
353	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
354	IF ( myid == 0 ) THEN
355	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
356	target_id, 15, comm_inter, status, ierr )
357	ENDIF
358	CALL MPI_BARRIER( comm2d, ierr )
359	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
360	0, comm2d, ierr )
361	uswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
362	!
363	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
364	IF ( myid == 0 ) THEN
365	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
366	target_id, 16, comm_inter, status, ierr )
367	ENDIF
368	CALL MPI_BARRIER( comm2d, ierr )
369	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
370	ierr )
371	vswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
372	!
373	!-- Send u to atmosphere
374	total_2d_o = 0.0_wp
375	total_2d = 0.0_wp
376	total_2d(nys:nyn,nxl:nxr) = u(nzt,nys:nyn,nxl:nxr)
377	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
378	comm2d, ierr )
379	CALL interpolate_to_atmos( 17 )
380	!
381	!-- Send v to atmosphere
382	total_2d_o = 0.0_wp
383	total_2d = 0.0_wp
384	total_2d(nys:nyn,nxl:nxr) = v(nzt,nys:nyn,nxl:nxr)
385	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
386	comm2d, ierr )
387	CALL interpolate_to_atmos( 18 )
388
389	ENDIF
390
391	!
392	!-- Conversions of fluxes received from atmosphere
393	IF ( humidity_remote ) THEN
394	!
395	!-- Here tswst is still the sum of atmospheric bottom heat fluxes,
396	!-- * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
397	!-- /(rho_atm(=1.0)*c_p)
398	tswst = tswst + qswst_remote * 2.2626108E6_wp / 1005.0_wp
399	!
400	!-- ...and convert it to a salinity flux at the sea surface (top)
401	!-- following Steinhorn (1991), JPO 21, pp. 1681-1683:
402	!-- S'w' = -S * evaporation / ( rho_water * ( 1 - S ) )
403	saswst = -1.0_wp * sa(nzt,:,:) * 0.001 * qswst_remote / &
404	( rho(nzt,:,:) * ( 1.0_wp - sa(nzt,:,:) * 0.001 ) )
405	ENDIF
406
407	!
408	!-- Adjust the kinematic heat flux with respect to ocean density
409	!-- (constants are the specific heat capacities for air and water)
410	!-- now tswst is the ocean top heat flux
411	tswst = tswst / rho(nzt,:,:) * 1005.0_wp / 4218.0_wp
412
413	!
414	!-- Adjust the momentum fluxes with respect to ocean density
415	uswst = uswst / rho(nzt,:,:)
416	vswst = vswst / rho(nzt,:,:)
417
418	ENDIF
419
420	IF ( coupling_topology == 1 ) THEN
421	DEALLOCATE( total_2d_o, total_2d_a )
422	ENDIF
423
424	CALL cpu_log( log_point(39), 'surface_coupler', 'stop' )
425
426	#endif
427
428	END SUBROUTINE surface_coupler
429
430
431
432	SUBROUTINE interpolate_to_atmos( tag )
433
434	#if defined( __parallel )
435
436	USE arrays_3d, &
437	ONLY: total_2d_a, total_2d_o
438
439	USE indices, &
440	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
441
442	USE kinds
443
444	USE pegrid
445
446	IMPLICIT NONE
447
448	INTEGER(iwp) :: dnx !:
449	INTEGER(iwp) :: dnx2 !:
450	INTEGER(iwp) :: dny !:
451	INTEGER(iwp) :: dny2 !:
452	INTEGER(iwp) :: i !:
453	INTEGER(iwp) :: ii !:
454	INTEGER(iwp) :: j !:
455	INTEGER(iwp) :: jj !:
456
457	INTEGER(iwp), intent(in) :: tag !:
458
459	CALL MPI_BARRIER( comm2d, ierr )
460
461	IF ( myid == 0 ) THEN
462	!
463	!-- Cyclic boundary conditions for the total 2D-grid
464	total_2d_o(-nbgp:-1,:) = total_2d_o(ny+1-nbgp:ny,:)
465	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx+1-nbgp:nx)
466
467	total_2d_o(ny+1:ny+nbgp,:) = total_2d_o(0:nbgp-1,:)
468	total_2d_o(:,nx+1:nx+nbgp) = total_2d_o(:,0:nbgp-1)
469
470	!
471	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
472	dnx = (nx_o+1) / (nx_a+1)
473	dny = (ny_o+1) / (ny_a+1)
474
475	!
476	!-- Distance for interpolation around coarse grid points within the fine
477	!-- grid (note: 2*dnx2 must not be equal with dnx)
478	dnx2 = 2 * ( dnx / 2 )
479	dny2 = 2 * ( dny / 2 )
480
481	total_2d_a = 0.0_wp
482	!
483	!-- Interpolation from ocean-grid-layer to atmosphere-grid-layer
484	DO j = 0, ny_a
485	DO i = 0, nx_a
486	DO jj = 0, dny2
487	DO ii = 0, dnx2
488	total_2d_a(j,i) = total_2d_a(j,i) &
489	+ total_2d_o(jdny+jj,idnx+ii)
490	ENDDO
491	ENDDO
492	total_2d_a(j,i) = total_2d_a(j,i) / ( ( dnx2 + 1 ) * ( dny2 + 1 ) )
493	ENDDO
494	ENDDO
495	!
496	!-- Cyclic boundary conditions for atmosphere grid
497	total_2d_a(-nbgp:-1,:) = total_2d_a(ny_a+1-nbgp:ny_a,:)
498	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx_a+1-nbgp:nx_a)
499
500	total_2d_a(ny_a+1:ny_a+nbgp,:) = total_2d_a(0:nbgp-1,:)
501	total_2d_a(:,nx_a+1:nx_a+nbgp) = total_2d_a(:,0:nbgp-1)
502	!
503	!-- Transfer of the atmosphere-grid-layer to the atmosphere
504	CALL MPI_SEND( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, target_id, &
505	tag, comm_inter, ierr )
506
507	ENDIF
508
509	CALL MPI_BARRIER( comm2d, ierr )
510
511	#endif
512
513	END SUBROUTINE interpolate_to_atmos
514
515
516	SUBROUTINE interpolate_to_ocean( tag )
517
518	#if defined( __parallel )
519
520	USE arrays_3d, &
521	ONLY: total_2d_a, total_2d_o
522
523	USE indices, &
524	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
525
526	USE kinds
527
528	USE pegrid
529
530	IMPLICIT NONE
531
532	INTEGER(iwp) :: dnx !:
533	INTEGER(iwp) :: dny !:
534	INTEGER(iwp) :: i !:
535	INTEGER(iwp) :: ii !:
536	INTEGER(iwp) :: j !:
537	INTEGER(iwp) :: jj !:
538	INTEGER(iwp), intent(in) :: tag !:
539
540	REAL(wp) :: fl !:
541	REAL(wp) :: fr !:
542	REAL(wp) :: myl !:
543	REAL(wp) :: myr !:
544
545	CALL MPI_BARRIER( comm2d, ierr )
546
547	IF ( myid == 0 ) THEN
548
549	!
550	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
551	dnx = ( nx_o + 1 ) / ( nx_a + 1 )
552	dny = ( ny_o + 1 ) / ( ny_a + 1 )
553
554	!
555	!-- Cyclic boundary conditions for atmosphere grid
556	total_2d_a(-nbgp:-1,:) = total_2d_a(ny+1-nbgp:ny,:)
557	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx+1-nbgp:nx)
558
559	total_2d_a(ny+1:ny+nbgp,:) = total_2d_a(0:nbgp-1,:)
560	total_2d_a(:,nx+1:nx+nbgp) = total_2d_a(:,0:nbgp-1)
561	!
562	!-- Bilinear Interpolation from atmosphere grid-layer to ocean grid-layer
563	DO j = 0, ny
564	DO i = 0, nx
565	myl = ( total_2d_a(j+1,i) - total_2d_a(j,i) ) / dny
566	myr = ( total_2d_a(j+1,i+1) - total_2d_a(j,i+1) ) / dny
567	DO jj = 0, dny-1
568	fl = myl*jj + total_2d_a(j,i)
569	fr = myr*jj + total_2d_a(j,i+1)
570	DO ii = 0, dnx-1
571	total_2d_o(jdny+jj,idnx+ii) = ( fr - fl ) / dnx * ii + fl
572	ENDDO
573	ENDDO
574	ENDDO
575	ENDDO
576	!
577	!-- Cyclic boundary conditions for ocean grid
578	total_2d_o(-nbgp:-1,:) = total_2d_o(ny_o+1-nbgp:ny_o,:)
579	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx_o+1-nbgp:nx_o)
580
581	total_2d_o(ny_o+1:ny_o+nbgp,:) = total_2d_o(0:nbgp-1,:)
582	total_2d_o(:,nx_o+1:nx_o+nbgp) = total_2d_o(:,0:nbgp-1)
583
584	CALL MPI_SEND( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
585	target_id, tag, comm_inter, ierr )
586
587	ENDIF
588
589	CALL MPI_BARRIER( comm2d, ierr )
590
591	#endif
592
593	END SUBROUTINE interpolate_to_ocean

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |