Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |