Home

Context Navigation

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

Last change on this file since 2232 was 2232, checked in by suehring, 7 years ago
Adjustments according new topography and surface-modelling concept implemented
Property svn:keywords set to `Id`
File size: 31.6 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |