Home

Context Navigation

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

Last change on this file since 2794 was 2718, checked in by maronga, 7 years ago
deleting of deprecated files; headers updated where needed
Property svn:keywords set to `Id`
File size: 31.8 KB

Line
1	!> @file surface_coupler.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! 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-2018 Leibniz Universitaet Hannover
18	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: surface_coupler.f90 2718 2018-01-02 08:49:38Z knoop $
27	! Corrected "Former revisions" section
28	!
29	! 2696 2017-12-14 17:12:51Z kanani
30	! Change in file header (GPL part)
31	!
32	! 2233 2017-05-30 18:08:54Z suehring
33	!
34	! 2232 2017-05-30 17:47:52Z suehring
35	! Adjust to new surface structure. Transfer 1D surface fluxes onto 2D grid
36	! (and back).
37	!
38	! 2031 2016-10-21 15:11:58Z knoop
39	! renamed variable rho to rho_ocean
40	!
41	! 2000 2016-08-20 18:09:15Z knoop
42	! Forced header and separation lines into 80 columns
43	!
44	! 1682 2015-10-07 23:56:08Z knoop
45	! Code annotations made doxygen readable
46	!
47	! 1427 2014-07-07 14:04:59Z maronga
48	! Bugfix: value of l_v corrected.
49	!
50	! 1418 2014-06-06 13:05:08Z fricke
51	! Bugfix: For caluclation of the salinity flux at the sea surface,
52	! the given value for salinity must be in percent and not in psu
53	!
54	! 1353 2014-04-08 15:21:23Z heinze
55	! REAL constants provided with KIND-attribute
56	!
57	! 1324 2014-03-21 09:13:16Z suehring
58	! Bugfix: ONLY statement for module pegrid removed
59	!
60	! 1322 2014-03-20 16:38:49Z raasch
61	! REAL constants defined as wp-kind
62	!
63	! 1320 2014-03-20 08:40:49Z raasch
64	! ONLY-attribute added to USE-statements,
65	! kind-parameters added to all INTEGER and REAL declaration statements,
66	! kinds are defined in new module kinds,
67	! old module precision_kind is removed,
68	! revision history before 2012 removed,
69	! comment fields (!:) to be used for variable explanations added to
70	! all variable declaration statements
71	!
72	! 1318 2014-03-17 13:35:16Z raasch
73	! module interfaces removed
74	!
75	! 1092 2013-02-02 11:24:22Z raasch
76	! unused variables removed
77	!
78	! 1036 2012-10-22 13:43:42Z raasch
79	! code put under GPL (PALM 3.9)
80	!
81	! 880 2012-04-13 06:28:59Z raasch
82	! Bugfix: preprocessor statements for parallel execution added
83	!
84	! 109 2007-08-28 15:26:47Z letzel
85	! Initial revision
86	!
87	! Description:
88	! ------------
89	!> Data exchange at the interface between coupled models
90	!------------------------------------------------------------------------------!
91	SUBROUTINE surface_coupler
92
93
94	USE arrays_3d, &
95	ONLY: pt, rho_ocean, sa, total_2d_a, total_2d_o, u, v
96
97	USE cloud_parameters, &
98	ONLY: cp, l_v
99
100	USE control_parameters, &
101	ONLY: coupling_mode, coupling_mode_remote, coupling_topology, &
102	humidity, humidity_remote, land_surface, message_string, &
103	terminate_coupled, terminate_coupled_remote, &
104	time_since_reference_point, urban_surface
105
106	USE cpulog, &
107	ONLY: cpu_log, log_point
108
109	USE indices, &
110	ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, nx_a, nx_o, ny, nyn, nyng, nys, &
111	nysg, ny_a, ny_o, nzt
112
113	USE kinds
114
115	USE pegrid
116
117	USE surface_mod, &
118	ONLY : surf_def_h, surf_lsm_h, surf_type, surf_usm_h
119
120	IMPLICIT NONE
121
122	INTEGER(iwp) :: i !< index variable x-direction
123	INTEGER(iwp) :: j !< index variable y-direction
124	INTEGER(iwp) :: m !< running index for surface elements
125
126	REAL(wp) :: cpw = 4218.0_wp !< heat capacity of water at constant pressure
127	REAL(wp) :: time_since_reference_point_rem !<
128	REAL(wp) :: total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !<
129
130	REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: surface_flux !< dummy array for surface fluxes on 2D grid
131
132
133	#if defined( __parallel )
134
135	CALL cpu_log( log_point(39), 'surface_coupler', 'start' )
136
137
138
139	!
140	!-- In case of model termination initiated by the remote model
141	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
142	!-- The rest of the coupler must then be skipped because it would cause an MPI
143	!-- intercomminucation hang.
144	!-- If necessary, the coupler will be called at the beginning of the next
145	!-- restart run.
146
147	IF ( coupling_topology == 0 ) THEN
148	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, target_id, &
149	0, &
150	terminate_coupled_remote, 1, MPI_INTEGER, target_id, &
151	0, comm_inter, status, ierr )
152	ELSE
153	IF ( myid == 0) THEN
154	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
155	target_id, 0, &
156	terminate_coupled_remote, 1, MPI_INTEGER, &
157	target_id, 0, &
158	comm_inter, status, ierr )
159	ENDIF
160	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
161	ierr )
162
163	ALLOCATE( total_2d_a(-nbgp:ny_a+nbgp,-nbgp:nx_a+nbgp), &
164	total_2d_o(-nbgp:ny_o+nbgp,-nbgp:nx_o+nbgp) )
165
166	ENDIF
167
168	IF ( terminate_coupled_remote > 0 ) THEN
169	WRITE( message_string, * ) 'remote model "', &
170	TRIM( coupling_mode_remote ), &
171	'" terminated', &
172	'&with terminate_coupled_remote = ', &
173	terminate_coupled_remote, &
174	'&local model "', TRIM( coupling_mode ), &
175	'" has', &
176	'&terminate_coupled = ', &
177	terminate_coupled
178	CALL message( 'surface_coupler', 'PA0310', 1, 2, 0, 6, 0 )
179	RETURN
180	ENDIF
181
182
183	!
184	!-- Exchange the current simulated time between the models,
185	!-- currently just for total_2d
186	IF ( coupling_topology == 0 ) THEN
187
188	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, 11, &
189	comm_inter, ierr )
190	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, target_id, &
191	11, comm_inter, status, ierr )
192	ELSE
193
194	IF ( myid == 0 ) THEN
195
196	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
197	11, comm_inter, ierr )
198	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
199	target_id, 11, comm_inter, status, ierr )
200
201	ENDIF
202
203	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
204	ierr )
205
206	ENDIF
207
208	!
209	!-- Exchange the interface data
210	IF ( coupling_mode == 'atmosphere_to_ocean' ) THEN
211
212	!
213	!-- Horizontal grid size and number of processors is equal in ocean and
214	!-- atmosphere
215	IF ( coupling_topology == 0 ) THEN
216
217	!
218	!-- Send heat flux at bottom surface to the ocean. First, transfer from
219	!-- 1D surface type to 2D grid.
220	CALL transfer_1D_to_2D_equal( surf_def_h(0)%shf, surf_lsm_h%shf, &
221	surf_usm_h%shf )
222	CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
223	12, comm_inter, ierr )
224	!
225	!-- Send humidity flux at bottom surface to the ocean. First, transfer
226	!-- from 1D surface type to 2D grid.
227	CALL transfer_1D_to_2D_equal( surf_def_h(0)%qsws, surf_lsm_h%qsws, &
228	surf_usm_h%qsws )
229	IF ( humidity ) THEN
230	CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
231	target_id, 13, comm_inter, ierr )
232	ENDIF
233	!
234	!-- Receive temperature at the bottom surface from the ocean
235	CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14, &
236	comm_inter, status, ierr )
237	!
238	!-- Send the momentum flux (u) at bottom surface to the ocean. First,
239	!-- transfer from 1D surface type to 2D grid.
240	CALL transfer_1D_to_2D_equal( surf_def_h(0)%usws, surf_lsm_h%usws, &
241	surf_usm_h%usws )
242	CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
243	15, comm_inter, ierr )
244	!
245	!-- Send the momentum flux (v) at bottom surface to the ocean. First,
246	!-- transfer from 1D surface type to 2D grid.
247	CALL transfer_1D_to_2D_equal( surf_def_h(0)%vsws, surf_lsm_h%vsws, &
248	surf_usm_h%vsws )
249	CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
250	16, comm_inter, ierr )
251	!
252	!-- Receive u at the bottom surface from the ocean
253	CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17, &
254	comm_inter, status, ierr )
255	!
256	!-- Receive v at the bottom surface from the ocean
257	CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18, &
258	comm_inter, status, ierr )
259	!
260	!-- Horizontal grid size or number of processors differs between
261	!-- ocean and atmosphere
262	ELSE
263
264	!
265	!-- Send heat flux at bottom surface to the ocean
266	total_2d_a = 0.0_wp
267	total_2d = 0.0_wp
268	!
269	!-- Transfer from 1D surface type to 2D grid.
270	CALL transfer_1D_to_2D_unequal( surf_def_h(0)%shf, surf_lsm_h%shf, &
271	surf_usm_h%shf )
272
273	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
274	comm2d, ierr )
275	CALL interpolate_to_ocean( 12 )
276	!
277	!-- Send humidity flux at bottom surface to the ocean
278	IF ( humidity ) THEN
279	total_2d_a = 0.0_wp
280	total_2d = 0.0_wp
281	!
282	!-- Transfer from 1D surface type to 2D grid.
283	CALL transfer_1D_to_2D_unequal( surf_def_h(0)%qsws, &
284	surf_lsm_h%qsws, &
285	surf_usm_h%qsws )
286
287	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, &
288	0, comm2d, ierr )
289	CALL interpolate_to_ocean( 13 )
290	ENDIF
291	!
292	!-- Receive temperature at the bottom surface from the ocean
293	IF ( myid == 0 ) THEN
294	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
295	target_id, 14, comm_inter, status, ierr )
296	ENDIF
297	CALL MPI_BARRIER( comm2d, ierr )
298	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
299	ierr )
300	pt(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
301	!
302	!-- Send momentum flux (u) at bottom surface to the ocean
303	total_2d_a = 0.0_wp
304	total_2d = 0.0_wp
305	!
306	!-- Transfer from 1D surface type to 2D grid.
307	CALL transfer_1D_to_2D_unequal( surf_def_h(0)%usws, surf_lsm_h%usws, &
308	surf_usm_h%usws )
309	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
310	comm2d, ierr )
311	CALL interpolate_to_ocean( 15 )
312	!
313	!-- Send momentum flux (v) at bottom surface to the ocean
314	total_2d_a = 0.0_wp
315	total_2d = 0.0_wp
316	!
317	!-- Transfer from 1D surface type to 2D grid.
318	CALL transfer_1D_to_2D_unequal( surf_def_h(0)%usws, surf_lsm_h%usws, &
319	surf_usm_h%usws )
320	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
321	comm2d, ierr )
322	CALL interpolate_to_ocean( 16 )
323	!
324	!-- Receive u at the bottom surface from the ocean
325	IF ( myid == 0 ) THEN
326	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
327	target_id, 17, comm_inter, status, ierr )
328	ENDIF
329	CALL MPI_BARRIER( comm2d, ierr )
330	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
331	ierr )
332	u(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
333	!
334	!-- Receive v at the bottom surface from the ocean
335	IF ( myid == 0 ) THEN
336	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
337	target_id, 18, comm_inter, status, ierr )
338	ENDIF
339	CALL MPI_BARRIER( comm2d, ierr )
340	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
341	ierr )
342	v(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
343
344	ENDIF
345
346	ELSEIF ( coupling_mode == 'ocean_to_atmosphere' ) THEN
347
348	!
349	!-- Horizontal grid size and number of processors is equal
350	!-- in ocean and atmosphere
351	IF ( coupling_topology == 0 ) THEN
352	!
353	!-- Receive heat flux at the sea surface (top) from the atmosphere
354	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
355	comm_inter, status, ierr )
356	CALL transfer_2D_to_1D_equal( surf_def_h(2)%shf )
357	!
358	!-- Receive humidity flux from the atmosphere (bottom)
359	!-- and add it to the heat flux at the sea surface (top)...
360	IF ( humidity_remote ) THEN
361	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
362	target_id, 13, comm_inter, status, ierr )
363	CALL transfer_2D_to_1D_equal( surf_def_h(2)%qsws )
364	ENDIF
365	!
366	!-- Send sea surface temperature to the atmosphere model
367	CALL MPI_SEND( pt(nzt,nysg,nxlg), 1, type_xy, target_id, 14, &
368	comm_inter, ierr )
369	!
370	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
371	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
372	comm_inter, status, ierr )
373	CALL transfer_2D_to_1D_equal( surf_def_h(2)%usws )
374	!
375	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
376	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
377	comm_inter, status, ierr )
378	CALL transfer_2D_to_1D_equal( surf_def_h(2)%vsws )
379	!
380	!-- Send u to the atmosphere
381	CALL MPI_SEND( u(nzt,nysg,nxlg), 1, type_xy, target_id, 17, &
382	comm_inter, ierr )
383	!
384	!-- Send v to the atmosphere
385	CALL MPI_SEND( v(nzt,nysg,nxlg), 1, type_xy, target_id, 18, &
386	comm_inter, ierr )
387	!
388	!-- Horizontal gridsize or number of processors differs between
389	!-- ocean and atmosphere
390	ELSE
391	!
392	!-- Receive heat flux at the sea surface (top) from the atmosphere
393	IF ( myid == 0 ) THEN
394	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
395	target_id, 12, comm_inter, status, ierr )
396	ENDIF
397	CALL MPI_BARRIER( comm2d, ierr )
398	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
399	ierr )
400	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%shf )
401	!
402	!-- Receive humidity flux at the sea surface (top) from the atmosphere
403	IF ( humidity_remote ) THEN
404	IF ( myid == 0 ) THEN
405	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
406	target_id, 13, comm_inter, status, ierr )
407	ENDIF
408	CALL MPI_BARRIER( comm2d, ierr )
409	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
410	comm2d, ierr)
411	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%qsws )
412	ENDIF
413	!
414	!-- Send surface temperature to atmosphere
415	total_2d_o = 0.0_wp
416	total_2d = 0.0_wp
417	total_2d(nys:nyn,nxl:nxr) = pt(nzt,nys:nyn,nxl:nxr)
418
419	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
420	comm2d, ierr)
421	CALL interpolate_to_atmos( 14 )
422	!
423	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
424	IF ( myid == 0 ) THEN
425	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
426	target_id, 15, comm_inter, status, ierr )
427	ENDIF
428	CALL MPI_BARRIER( comm2d, ierr )
429	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
430	0, comm2d, ierr )
431	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%usws )
432	!
433	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
434	IF ( myid == 0 ) THEN
435	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
436	target_id, 16, comm_inter, status, ierr )
437	ENDIF
438	CALL MPI_BARRIER( comm2d, ierr )
439	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
440	ierr )
441	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%vsws )
442	!
443	!-- Send u to atmosphere
444	total_2d_o = 0.0_wp
445	total_2d = 0.0_wp
446	total_2d(nys:nyn,nxl:nxr) = u(nzt,nys:nyn,nxl:nxr)
447	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
448	comm2d, ierr )
449	CALL interpolate_to_atmos( 17 )
450	!
451	!-- Send v to atmosphere
452	total_2d_o = 0.0_wp
453	total_2d = 0.0_wp
454	total_2d(nys:nyn,nxl:nxr) = v(nzt,nys:nyn,nxl:nxr)
455	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
456	comm2d, ierr )
457	CALL interpolate_to_atmos( 18 )
458
459	ENDIF
460
461	!
462	!-- Conversions of fluxes received from atmosphere
463	IF ( humidity_remote ) THEN
464	!
465	!-- Here top heat flux is still the sum of atmospheric bottom heat fluxes,
466	!-- * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
467	!-- /(rho_atm(=1.0)*c_p)
468	DO m = 1, surf_def_h(2)%ns
469	i = surf_def_h(2)%i(m)
470	j = surf_def_h(2)%j(m)
471
472	surf_def_h(2)%shf(m) = surf_def_h(2)%shf(m) + &
473	surf_def_h(2)%qsws(m) * l_v / cp
474	!
475	!-- ...and convert it to a salinity flux at the sea surface (top)
476	!-- following Steinhorn (1991), JPO 21, pp. 1681-1683:
477	!-- S'w' = -S * evaporation / ( rho_water * ( 1 - S ) )
478	surf_def_h(2)%sasws(m) = -1.0_wp * sa(nzt,j,i) * 0.001_wp * &
479	surf_def_h(2)%qsws(m) / &
480	( rho_ocean(nzt,j,i) * &
481	( 1.0_wp - sa(nzt,j,i) * 0.001_wp ) &
482	)
483	ENDDO
484	ENDIF
485
486	!
487	!-- Adjust the kinematic heat flux with respect to ocean density
488	!-- (constants are the specific heat capacities for air and water), as well
489	!-- as momentum fluxes
490	DO m = 1, surf_def_h(2)%ns
491	i = surf_def_h(2)%i(m)
492	j = surf_def_h(2)%j(m)
493	surf_def_h(2)%shf(m) = surf_def_h(2)%shf(m) / rho_ocean(nzt,j,i) * &
494	cp / cpw
495
496	surf_def_h(2)%usws(m) = surf_def_h(2)%usws(m) / rho_ocean(nzt,j,i)
497	surf_def_h(2)%vsws(m) = surf_def_h(2)%vsws(m) / rho_ocean(nzt,j,i)
498	ENDDO
499
500	ENDIF
501
502	IF ( coupling_topology == 1 ) THEN
503	DEALLOCATE( total_2d_o, total_2d_a )
504	ENDIF
505
506	CALL cpu_log( log_point(39), 'surface_coupler', 'stop' )
507
508	#endif
509
510	CONTAINS
511
512	! Description:
513	!------------------------------------------------------------------------------!
514	!> Data transfer from 1D surface-data type to 2D dummy array for equal
515	!> grids in atmosphere and ocean.
516	!------------------------------------------------------------------------------!
517	SUBROUTINE transfer_1D_to_2D_equal( def_1d, lsm_1d, usm_1d )
518
519	IMPLICIT NONE
520
521	INTEGER(iwp) :: i !< running index x
522	INTEGER(iwp) :: j !< running index y
523	INTEGER(iwp) :: m !< running index surface type
524
525	REAL(wp), DIMENSION(1:surf_def_h(0)%ns) :: def_1d !< 1D surface flux, default surfaces
526	REAL(wp), DIMENSION(1:surf_lsm_h%ns) :: lsm_1d !< 1D surface flux, natural surfaces
527	REAL(wp), DIMENSION(1:surf_usm_h%ns) :: usm_1d !< 1D surface flux, urban surfaces
528	!
529	!-- Transfer surface flux at default surfaces to 2D grid
530	DO m = 1, surf_def_h(0)%ns
531	i = surf_def_h(0)%i(m)
532	j = surf_def_h(0)%j(m)
533	surface_flux(j,i) = def_1d(m)
534	ENDDO
535	!
536	!-- Transfer surface flux at natural surfaces to 2D grid
537	IF ( land_surface ) THEN
538	DO m = 1, SIZE(lsm_1d)
539	i = surf_lsm_h%i(m)
540	j = surf_lsm_h%j(m)
541	surface_flux(j,i) = lsm_1d(m)
542	ENDDO
543	ENDIF
544	!
545	!-- Transfer surface flux at natural surfaces to 2D grid
546	IF ( urban_surface ) THEN
547	DO m = 1, SIZE(usm_1d)
548	i = surf_usm_h%i(m)
549	j = surf_usm_h%j(m)
550	surface_flux(j,i) = usm_1d(m)
551	ENDDO
552	ENDIF
553
554	END SUBROUTINE transfer_1D_to_2D_equal
555
556	! Description:
557	!------------------------------------------------------------------------------!
558	!> Data transfer from 2D array for equal grids onto 1D surface-data type
559	!> array.
560	!------------------------------------------------------------------------------!
561	SUBROUTINE transfer_2D_to_1D_equal( def_1d )
562
563	IMPLICIT NONE
564
565	INTEGER(iwp) :: i !< running index x
566	INTEGER(iwp) :: j !< running index y
567	INTEGER(iwp) :: m !< running index surface type
568
569	REAL(wp), DIMENSION(1:surf_def_h(2)%ns) :: def_1d !< 1D surface flux, default surfaces
570	!
571	!-- Transfer surface flux to 1D surface type, only for default surfaces
572	DO m = 1, surf_def_h(2)%ns
573	i = surf_def_h(2)%i(m)
574	j = surf_def_h(2)%j(m)
575	def_1d(m) = surface_flux(j,i)
576	ENDDO
577
578	END SUBROUTINE transfer_2D_to_1D_equal
579
580	! Description:
581	!------------------------------------------------------------------------------!
582	!> Data transfer from 1D surface-data type to 2D dummy array from unequal
583	!> grids in atmosphere and ocean.
584	!------------------------------------------------------------------------------!
585	SUBROUTINE transfer_1D_to_2D_unequal( def_1d, lsm_1d, usm_1d )
586
587	IMPLICIT NONE
588
589	INTEGER(iwp) :: i !< running index x
590	INTEGER(iwp) :: j !< running index y
591	INTEGER(iwp) :: m !< running index surface type
592
593	REAL(wp), DIMENSION(1:surf_def_h(0)%ns) :: def_1d !< 1D surface flux, default surfaces
594	REAL(wp), DIMENSION(1:surf_lsm_h%ns) :: lsm_1d !< 1D surface flux, natural surfaces
595	REAL(wp), DIMENSION(1:surf_usm_h%ns) :: usm_1d !< 1D surface flux, urban surfaces
596	!
597	!-- Transfer surface flux at default surfaces to 2D grid. Transfer no
598	!-- ghost-grid points since total_2d is a global array.
599	DO m = 1, SIZE(def_1d)
600	i = surf_def_h(0)%i(m)
601	j = surf_def_h(0)%j(m)
602
603	IF ( i >= nxl .AND. i <= nxr .AND. &
604	j >= nys .AND. j <= nyn ) THEN
605	total_2d(j,i) = def_1d(m)
606	ENDIF
607	ENDDO
608	!
609	!-- Transfer surface flux at natural surfaces to 2D grid
610	IF ( land_surface ) THEN
611	DO m = 1, SIZE(lsm_1d)
612	i = surf_lsm_h%i(m)
613	j = surf_lsm_h%j(m)
614
615	IF ( i >= nxl .AND. i <= nxr .AND. &
616	j >= nys .AND. j <= nyn ) THEN
617	total_2d(j,i) = lsm_1d(m)
618	ENDIF
619	ENDDO
620	ENDIF
621	!
622	!-- Transfer surface flux at natural surfaces to 2D grid
623	IF ( urban_surface ) THEN
624	DO m = 1, SIZE(usm_1d)
625	i = surf_usm_h%i(m)
626	j = surf_usm_h%j(m)
627
628	IF ( i >= nxl .AND. i <= nxr .AND. &
629	j >= nys .AND. j <= nyn ) THEN
630	total_2d(j,i) = usm_1d(m)
631	ENDIF
632	ENDDO
633	ENDIF
634
635	END SUBROUTINE transfer_1D_to_2D_unequal
636
637	! Description:
638	!------------------------------------------------------------------------------!
639	!> Data transfer from 2D dummy array from unequal grids to 1D surface-data
640	!> type.
641	!------------------------------------------------------------------------------!
642	SUBROUTINE transfer_2D_to_1D_unequal( def_1d )
643
644	IMPLICIT NONE
645
646	INTEGER(iwp) :: i !< running index x
647	INTEGER(iwp) :: j !< running index y
648	INTEGER(iwp) :: m !< running index surface type
649
650	REAL(wp), DIMENSION(1:surf_def_h(2)%ns) :: def_1d !< 1D surface flux, default surfaces
651	!
652	!-- Transfer 2D surface flux to default surfaces data type. Transfer no
653	!-- ghost-grid points since total_2d is a global array.
654	DO m = 1, SIZE(def_1d)
655	i = surf_def_h(2)%i(m)
656	j = surf_def_h(2)%j(m)
657
658	IF ( i >= nxl .AND. i <= nxr .AND. &
659	j >= nys .AND. j <= nyn ) THEN
660	def_1d(m) = total_2d_o(j,i)
661	ENDIF
662	ENDDO
663
664
665	END SUBROUTINE transfer_2D_to_1D_unequal
666
667	END SUBROUTINE surface_coupler
668
669
670
671	!------------------------------------------------------------------------------!
672	! Description:
673	! ------------
674	!> @todo Missing subroutine description.
675	!------------------------------------------------------------------------------!
676	SUBROUTINE interpolate_to_atmos( tag )
677
678	#if defined( __parallel )
679
680	USE arrays_3d, &
681	ONLY: total_2d_a, total_2d_o
682
683	USE indices, &
684	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
685
686	USE kinds
687
688	USE pegrid
689
690	IMPLICIT NONE
691
692	INTEGER(iwp) :: dnx !<
693	INTEGER(iwp) :: dnx2 !<
694	INTEGER(iwp) :: dny !<
695	INTEGER(iwp) :: dny2 !<
696	INTEGER(iwp) :: i !<
697	INTEGER(iwp) :: ii !<
698	INTEGER(iwp) :: j !<
699	INTEGER(iwp) :: jj !<
700
701	INTEGER(iwp), intent(in) :: tag !<
702
703	CALL MPI_BARRIER( comm2d, ierr )
704
705	IF ( myid == 0 ) THEN
706	!
707	!-- Cyclic boundary conditions for the total 2D-grid
708	total_2d_o(-nbgp:-1,:) = total_2d_o(ny+1-nbgp:ny,:)
709	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx+1-nbgp:nx)
710
711	total_2d_o(ny+1:ny+nbgp,:) = total_2d_o(0:nbgp-1,:)
712	total_2d_o(:,nx+1:nx+nbgp) = total_2d_o(:,0:nbgp-1)
713
714	!
715	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
716	dnx = (nx_o+1) / (nx_a+1)
717	dny = (ny_o+1) / (ny_a+1)
718
719	!
720	!-- Distance for interpolation around coarse grid points within the fine
721	!-- grid (note: 2*dnx2 must not be equal with dnx)
722	dnx2 = 2 * ( dnx / 2 )
723	dny2 = 2 * ( dny / 2 )
724
725	total_2d_a = 0.0_wp
726	!
727	!-- Interpolation from ocean-grid-layer to atmosphere-grid-layer
728	DO j = 0, ny_a
729	DO i = 0, nx_a
730	DO jj = 0, dny2
731	DO ii = 0, dnx2
732	total_2d_a(j,i) = total_2d_a(j,i) &
733	+ total_2d_o(jdny+jj,idnx+ii)
734	ENDDO
735	ENDDO
736	total_2d_a(j,i) = total_2d_a(j,i) / ( ( dnx2 + 1 ) * ( dny2 + 1 ) )
737	ENDDO
738	ENDDO
739	!
740	!-- Cyclic boundary conditions for atmosphere grid
741	total_2d_a(-nbgp:-1,:) = total_2d_a(ny_a+1-nbgp:ny_a,:)
742	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx_a+1-nbgp:nx_a)
743
744	total_2d_a(ny_a+1:ny_a+nbgp,:) = total_2d_a(0:nbgp-1,:)
745	total_2d_a(:,nx_a+1:nx_a+nbgp) = total_2d_a(:,0:nbgp-1)
746	!
747	!-- Transfer of the atmosphere-grid-layer to the atmosphere
748	CALL MPI_SEND( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, target_id, &
749	tag, comm_inter, ierr )
750
751	ENDIF
752
753	CALL MPI_BARRIER( comm2d, ierr )
754
755	#endif
756
757	END SUBROUTINE interpolate_to_atmos
758
759
760	!------------------------------------------------------------------------------!
761	! Description:
762	! ------------
763	!> @todo Missing subroutine description.
764	!------------------------------------------------------------------------------!
765	SUBROUTINE interpolate_to_ocean( tag )
766
767	#if defined( __parallel )
768
769	USE arrays_3d, &
770	ONLY: total_2d_a, total_2d_o
771
772	USE indices, &
773	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
774
775	USE kinds
776
777	USE pegrid
778
779	IMPLICIT NONE
780
781	INTEGER(iwp) :: dnx !<
782	INTEGER(iwp) :: dny !<
783	INTEGER(iwp) :: i !<
784	INTEGER(iwp) :: ii !<
785	INTEGER(iwp) :: j !<
786	INTEGER(iwp) :: jj !<
787	INTEGER(iwp), intent(in) :: tag !<
788
789	REAL(wp) :: fl !<
790	REAL(wp) :: fr !<
791	REAL(wp) :: myl !<
792	REAL(wp) :: myr !<
793
794	CALL MPI_BARRIER( comm2d, ierr )
795
796	IF ( myid == 0 ) THEN
797
798	!
799	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
800	dnx = ( nx_o + 1 ) / ( nx_a + 1 )
801	dny = ( ny_o + 1 ) / ( ny_a + 1 )
802
803	!
804	!-- Cyclic boundary conditions for atmosphere grid
805	total_2d_a(-nbgp:-1,:) = total_2d_a(ny+1-nbgp:ny,:)
806	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx+1-nbgp:nx)
807
808	total_2d_a(ny+1:ny+nbgp,:) = total_2d_a(0:nbgp-1,:)
809	total_2d_a(:,nx+1:nx+nbgp) = total_2d_a(:,0:nbgp-1)
810	!
811	!-- Bilinear Interpolation from atmosphere grid-layer to ocean grid-layer
812	DO j = 0, ny
813	DO i = 0, nx
814	myl = ( total_2d_a(j+1,i) - total_2d_a(j,i) ) / dny
815	myr = ( total_2d_a(j+1,i+1) - total_2d_a(j,i+1) ) / dny
816	DO jj = 0, dny-1
817	fl = myl*jj + total_2d_a(j,i)
818	fr = myr*jj + total_2d_a(j,i+1)
819	DO ii = 0, dnx-1
820	total_2d_o(jdny+jj,idnx+ii) = ( fr - fl ) / dnx * ii + fl
821	ENDDO
822	ENDDO
823	ENDDO
824	ENDDO
825	!
826	!-- Cyclic boundary conditions for ocean grid
827	total_2d_o(-nbgp:-1,:) = total_2d_o(ny_o+1-nbgp:ny_o,:)
828	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx_o+1-nbgp:nx_o)
829
830	total_2d_o(ny_o+1:ny_o+nbgp,:) = total_2d_o(0:nbgp-1,:)
831	total_2d_o(:,nx_o+1:nx_o+nbgp) = total_2d_o(:,0:nbgp-1)
832
833	CALL MPI_SEND( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
834	target_id, tag, comm_inter, ierr )
835
836	ENDIF
837
838	CALL MPI_BARRIER( comm2d, ierr )
839
840	#endif
841
842	END SUBROUTINE interpolate_to_ocean

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |