Home

Context Navigation

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

Last change on this file since 3215 was 3049, checked in by Giersch, 6 years ago
Revision history corrected
Property svn:keywords set to `Id`
File size: 31.9 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |