Home

Context Navigation

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

Last change on this file since 3753 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

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	!
[3655]	17	! Copyright 1997-2019 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 3655 2019-01-07 16:51:22Z dom_dwd_user $
[3274]	27	! Modularization of all bulk cloud physics code components
	28	!
	29	! 3049 2018-05-29 13:52:36Z Giersch
[3049]	30	! Error messages revised
	31	!
	32	! 3045 2018-05-28 07:55:41Z Giersch
[3045]	33	! Error message revised
	34	!
	35	! 2718 2018-01-02 08:49:38Z maronga
[2716]	36	! Corrected "Former revisions" section
	37	!
	38	! 2696 2017-12-14 17:12:51Z kanani
	39	! Change in file header (GPL part)
[1321]	40	!
[2716]	41	! 2233 2017-05-30 18:08:54Z suehring
	42	!
[2233]	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	!
[2032]	47	! 2031 2016-10-21 15:11:58Z knoop
	48	! renamed variable rho to rho_ocean
	49	!
[2001]	50	! 2000 2016-08-20 18:09:15Z knoop
	51	! Forced header and separation lines into 80 columns
	52	!
[1683]	53	! 1682 2015-10-07 23:56:08Z knoop
	54	! Code annotations made doxygen readable
	55	!
[1428]	56	! 1427 2014-07-07 14:04:59Z maronga
	57	! Bugfix: value of l_v corrected.
	58	!
[1419]	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	!
[1354]	63	! 1353 2014-04-08 15:21:23Z heinze
	64	! REAL constants provided with KIND-attribute
	65	!
[1325]	66	! 1324 2014-03-21 09:13:16Z suehring
	67	! Bugfix: ONLY statement for module pegrid removed
	68	!
[1323]	69	! 1322 2014-03-20 16:38:49Z raasch
	70	! REAL constants defined as wp-kind
	71	!
[1321]	72	! 1320 2014-03-20 08:40:49Z raasch
[1320]	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
[102]	80	!
[1319]	81	! 1318 2014-03-17 13:35:16Z raasch
	82	! module interfaces removed
	83	!
[1093]	84	! 1092 2013-02-02 11:24:22Z raasch
	85	! unused variables removed
	86	!
[1037]	87	! 1036 2012-10-22 13:43:42Z raasch
	88	! code put under GPL (PALM 3.9)
	89	!
[881]	90	! 880 2012-04-13 06:28:59Z raasch
	91	! Bugfix: preprocessor statements for parallel execution added
	92	!
[110]	93	! 109 2007-08-28 15:26:47Z letzel
[102]	94	! Initial revision
	95	!
	96	! Description:
	97	! ------------
[1682]	98	!> Data exchange at the interface between coupled models
[102]	99	!------------------------------------------------------------------------------!
[1682]	100	SUBROUTINE surface_coupler
	101
[102]	102
[1320]	103	USE arrays_3d, &
[2232]	104	ONLY: pt, rho_ocean, sa, total_2d_a, total_2d_o, u, v
[1320]	105
[3274]	106	USE basic_constants_and_equations_mod, &
	107	ONLY: c_p, l_v
[1427]	108
[1320]	109	USE control_parameters, &
	110	ONLY: coupling_mode, coupling_mode_remote, coupling_topology, &
[2232]	111	humidity, humidity_remote, land_surface, message_string, &
	112	terminate_coupled, terminate_coupled_remote, &
	113	time_since_reference_point, urban_surface
[1320]	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
[102]	124	USE pegrid
	125
[2232]	126	USE surface_mod, &
	127	ONLY : surf_def_h, surf_lsm_h, surf_type, surf_usm_h
	128
[102]	129	IMPLICIT NONE
	130
[2232]	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
[1682]	136	REAL(wp) :: time_since_reference_point_rem !<
	137	REAL(wp) :: total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !<
[102]	138
[2232]	139	REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: surface_flux !< dummy array for surface fluxes on 2D grid
[1427]	140
[2232]	141
[206]	142	#if defined( __parallel )
[102]	143
[667]	144	CALL cpu_log( log_point(39), 'surface_coupler', 'start' )
[102]	145
[667]	146
	147
[102]	148	!
[108]	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.
[667]	155
	156	IF ( coupling_topology == 0 ) THEN
[709]	157	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, target_id, &
	158	0, &
	159	terminate_coupled_remote, 1, MPI_INTEGER, target_id, &
[667]	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
[709]	169	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
	170	ierr )
[667]	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
[108]	177	IF ( terminate_coupled_remote > 0 ) THEN
[3045]	178	WRITE( message_string, * ) 'remote model "', &
	179	TRIM( coupling_mode_remote ), &
	180	'" terminated', &
[3046]	181	'&with terminate_coupled_remote = ', &
[3045]	182	terminate_coupled_remote, &
[3046]	183	'&local model "', TRIM( coupling_mode ), &
[3045]	184	'" has', &
[3046]	185	'&terminate_coupled = ', &
[667]	186	terminate_coupled
[258]	187	CALL message( 'surface_coupler', 'PA0310', 1, 2, 0, 6, 0 )
[108]	188	RETURN
	189	ENDIF
[667]	190
[291]	191
[108]	192	!
	193	!-- Exchange the current simulated time between the models,
[2232]	194	!-- currently just for total_2d
[709]	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 )
[667]	201	ELSE
[709]	202
[667]	203	IF ( myid == 0 ) THEN
[709]	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, &
[667]	208	target_id, 11, comm_inter, status, ierr )
[709]	209
[667]	210	ENDIF
[709]	211
	212	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
	213	ierr )
	214
[667]	215	ENDIF
[102]	216
	217	!
	218	!-- Exchange the interface data
	219	IF ( coupling_mode == 'atmosphere_to_ocean' ) THEN
[667]	220
	221	!
[709]	222	!-- Horizontal grid size and number of processors is equal in ocean and
	223	!-- atmosphere
	224	IF ( coupling_topology == 0 ) THEN
[102]	225
	226	!
[2232]	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 )
[102]	233	!
[2232]	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 )
[667]	238	IF ( humidity ) THEN
[2232]	239	CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
	240	target_id, 13, comm_inter, ierr )
[667]	241	ENDIF
	242	!
[709]	243	!-- Receive temperature at the bottom surface from the ocean
[2232]	244	CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14, &
[709]	245	comm_inter, status, ierr )
[108]	246	!
[2232]	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 )
[102]	253	!
[2232]	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 )
[102]	260	!
[709]	261	!-- Receive u at the bottom surface from the ocean
[2232]	262	CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17, &
[709]	263	comm_inter, status, ierr )
[667]	264	!
[709]	265	!-- Receive v at the bottom surface from the ocean
[2232]	266	CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18, &
[709]	267	comm_inter, status, ierr )
[667]	268	!
	269	!-- Horizontal grid size or number of processors differs between
	270	!-- ocean and atmosphere
	271	ELSE
	272
	273	!
[709]	274	!-- Send heat flux at bottom surface to the ocean
[1353]	275	total_2d_a = 0.0_wp
	276	total_2d = 0.0_wp
[2232]	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 )
[709]	281
[2232]	282	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
[709]	283	comm2d, ierr )
	284	CALL interpolate_to_ocean( 12 )
[667]	285	!
[709]	286	!-- Send humidity flux at bottom surface to the ocean
	287	IF ( humidity ) THEN
[1353]	288	total_2d_a = 0.0_wp
	289	total_2d = 0.0_wp
[2232]	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 )
[709]	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 )
[667]	299	ENDIF
	300	!
[709]	301	!-- Receive temperature at the bottom surface from the ocean
	302	IF ( myid == 0 ) THEN
[2232]	303	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
[667]	304	target_id, 14, comm_inter, status, ierr )
	305	ENDIF
	306	CALL MPI_BARRIER( comm2d, ierr )
[709]	307	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	308	ierr )
[667]	309	pt(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	310	!
[709]	311	!-- Send momentum flux (u) at bottom surface to the ocean
[1353]	312	total_2d_a = 0.0_wp
	313	total_2d = 0.0_wp
[2232]	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 )
[709]	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 )
[667]	321	!
[709]	322	!-- Send momentum flux (v) at bottom surface to the ocean
[1353]	323	total_2d_a = 0.0_wp
	324	total_2d = 0.0_wp
[2232]	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 )
[709]	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 )
[667]	332	!
[709]	333	!-- Receive u at the bottom surface from the ocean
	334	IF ( myid == 0 ) THEN
[667]	335	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
[709]	336	target_id, 17, comm_inter, status, ierr )
[667]	337	ENDIF
	338	CALL MPI_BARRIER( comm2d, ierr )
[709]	339	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	340	ierr )
[667]	341	u(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	342	!
[709]	343	!-- Receive v at the bottom surface from the ocean
	344	IF ( myid == 0 ) THEN
[667]	345	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
[709]	346	target_id, 18, comm_inter, status, ierr )
[667]	347	ENDIF
	348	CALL MPI_BARRIER( comm2d, ierr )
[709]	349	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	350	ierr )
[667]	351	v(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	352
	353	ENDIF
	354
[102]	355	ELSEIF ( coupling_mode == 'ocean_to_atmosphere' ) THEN
	356
	357	!
[667]	358	!-- Horizontal grid size and number of processors is equal
	359	!-- in ocean and atmosphere
	360	IF ( coupling_topology == 0 ) THEN
	361	!
[709]	362	!-- Receive heat flux at the sea surface (top) from the atmosphere
[2232]	363	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
[709]	364	comm_inter, status, ierr )
[2232]	365	CALL transfer_2D_to_1D_equal( surf_def_h(2)%shf )
[102]	366	!
[709]	367	!-- Receive humidity flux from the atmosphere (bottom)
[667]	368	!-- and add it to the heat flux at the sea surface (top)...
	369	IF ( humidity_remote ) THEN
[2232]	370	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
[667]	371	target_id, 13, comm_inter, status, ierr )
[2232]	372	CALL transfer_2D_to_1D_equal( surf_def_h(2)%qsws )
[667]	373	ENDIF
	374	!
	375	!-- Send sea surface temperature to the atmosphere model
[709]	376	CALL MPI_SEND( pt(nzt,nysg,nxlg), 1, type_xy, target_id, 14, &
	377	comm_inter, ierr )
[667]	378	!
	379	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
[2232]	380	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
[709]	381	comm_inter, status, ierr )
[2232]	382	CALL transfer_2D_to_1D_equal( surf_def_h(2)%usws )
[667]	383	!
	384	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
[2232]	385	CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
[709]	386	comm_inter, status, ierr )
[2232]	387	CALL transfer_2D_to_1D_equal( surf_def_h(2)%vsws )
[667]	388	!
[709]	389	!-- Send u to the atmosphere
	390	CALL MPI_SEND( u(nzt,nysg,nxlg), 1, type_xy, target_id, 17, &
	391	comm_inter, ierr )
[667]	392	!
[709]	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	!
[667]	397	!-- Horizontal gridsize or number of processors differs between
	398	!-- ocean and atmosphere
	399	ELSE
	400	!
[709]	401	!-- Receive heat flux at the sea surface (top) from the atmosphere
	402	IF ( myid == 0 ) THEN
[667]	403	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	404	target_id, 12, comm_inter, status, ierr )
[667]	405	ENDIF
	406	CALL MPI_BARRIER( comm2d, ierr )
[709]	407	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
	408	ierr )
[2232]	409	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%shf )
[667]	410	!
[709]	411	!-- Receive humidity flux at the sea surface (top) from the atmosphere
	412	IF ( humidity_remote ) THEN
	413	IF ( myid == 0 ) THEN
[667]	414	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	415	target_id, 13, comm_inter, status, ierr )
[667]	416	ENDIF
	417	CALL MPI_BARRIER( comm2d, ierr )
[709]	418	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
	419	comm2d, ierr)
[2232]	420	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%qsws )
[667]	421	ENDIF
	422	!
	423	!-- Send surface temperature to atmosphere
[1353]	424	total_2d_o = 0.0_wp
	425	total_2d = 0.0_wp
[667]	426	total_2d(nys:nyn,nxl:nxr) = pt(nzt,nys:nyn,nxl:nxr)
	427
[709]	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 )
[667]	431	!
[709]	432	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
	433	IF ( myid == 0 ) THEN
[667]	434	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	435	target_id, 15, comm_inter, status, ierr )
[667]	436	ENDIF
	437	CALL MPI_BARRIER( comm2d, ierr )
	438	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	439	0, comm2d, ierr )
[2232]	440	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%usws )
[667]	441	!
[709]	442	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
	443	IF ( myid == 0 ) THEN
[667]	444	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	445	target_id, 16, comm_inter, status, ierr )
[667]	446	ENDIF
	447	CALL MPI_BARRIER( comm2d, ierr )
[709]	448	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
	449	ierr )
[2232]	450	CALL transfer_2D_to_1D_unequal( surf_def_h(2)%vsws )
[667]	451	!
	452	!-- Send u to atmosphere
[1353]	453	total_2d_o = 0.0_wp
	454	total_2d = 0.0_wp
[667]	455	total_2d(nys:nyn,nxl:nxr) = u(nzt,nys:nyn,nxl:nxr)
[709]	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 )
[667]	459	!
	460	!-- Send v to atmosphere
[1353]	461	total_2d_o = 0.0_wp
	462	total_2d = 0.0_wp
[667]	463	total_2d(nys:nyn,nxl:nxr) = v(nzt,nys:nyn,nxl:nxr)
[709]	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 )
[667]	467
	468	ENDIF
	469
	470	!
	471	!-- Conversions of fluxes received from atmosphere
	472	IF ( humidity_remote ) THEN
[108]	473	!
[2232]	474	!-- Here top heat flux is still the sum of atmospheric bottom heat fluxes,
[709]	475	!-- * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
	476	!-- /(rho_atm(=1.0)*c_p)
[2232]	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) + &
[3274]	482	surf_def_h(2)%qsws(m) * l_v / c_p
[709]	483	!
[2232]	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
[108]	493	ENDIF
	494
	495	!
[102]	496	!-- Adjust the kinematic heat flux with respect to ocean density
[2232]	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) * &
[3274]	503	c_p / cpw
[102]	504
[2232]	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
[102]	508
[667]	509	ENDIF
	510
[709]	511	IF ( coupling_topology == 1 ) THEN
[667]	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
[2232]	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
[667]	676	END SUBROUTINE surface_coupler
	677
	678
	679
[1682]	680	!------------------------------------------------------------------------------!
	681	! Description:
	682	! ------------
	683	!> @todo Missing subroutine description.
	684	!------------------------------------------------------------------------------!
[709]	685	SUBROUTINE interpolate_to_atmos( tag )
[667]	686
[880]	687	#if defined( __parallel )
	688
[1320]	689	USE arrays_3d, &
	690	ONLY: total_2d_a, total_2d_o
[667]	691
[1320]	692	USE indices, &
	693	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
	694
	695	USE kinds
	696
[1324]	697	USE pegrid
[1320]	698
[667]	699	IMPLICIT NONE
	700
[1682]	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 !<
[667]	709
[1682]	710	INTEGER(iwp), intent(in) :: tag !<
[1320]	711
[667]	712	CALL MPI_BARRIER( comm2d, ierr )
	713
[709]	714	IF ( myid == 0 ) THEN
	715	!
	716	!-- Cyclic boundary conditions for the total 2D-grid
[667]	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
[102]	723	!
[667]	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)
[102]	727
	728	!
[709]	729	!-- Distance for interpolation around coarse grid points within the fine
	730	!-- grid (note: 2*dnx2 must not be equal with dnx)
[667]	731	dnx2 = 2 * ( dnx / 2 )
	732	dny2 = 2 * ( dny / 2 )
[102]	733
[1353]	734	total_2d_a = 0.0_wp
[102]	735	!
[667]	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	!
[709]	749	!-- Cyclic boundary conditions for atmosphere grid
[667]	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
[709]	757	CALL MPI_SEND( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, target_id, &
	758	tag, comm_inter, ierr )
[102]	759
	760	ENDIF
	761
[667]	762	CALL MPI_BARRIER( comm2d, ierr )
[102]	763
[880]	764	#endif
	765
[667]	766	END SUBROUTINE interpolate_to_atmos
[102]	767
[667]	768
[1682]	769	!------------------------------------------------------------------------------!
	770	! Description:
	771	! ------------
	772	!> @todo Missing subroutine description.
	773	!------------------------------------------------------------------------------!
[709]	774	SUBROUTINE interpolate_to_ocean( tag )
[667]	775
[880]	776	#if defined( __parallel )
	777
[1320]	778	USE arrays_3d, &
	779	ONLY: total_2d_a, total_2d_o
[667]	780
[1320]	781	USE indices, &
	782	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
	783
	784	USE kinds
	785
[1324]	786	USE pegrid
[1320]	787
[667]	788	IMPLICIT NONE
	789
[1682]	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 !<
[667]	797
[1682]	798	REAL(wp) :: fl !<
	799	REAL(wp) :: fr !<
	800	REAL(wp) :: myl !<
	801	REAL(wp) :: myr !<
[709]	802
[667]	803	CALL MPI_BARRIER( comm2d, ierr )
	804
[709]	805	IF ( myid == 0 ) THEN
[667]	806
	807	!
[709]	808	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
[667]	809	dnx = ( nx_o + 1 ) / ( nx_a + 1 )
	810	dny = ( ny_o + 1 ) / ( ny_a + 1 )
	811
	812	!
[709]	813	!-- Cyclic boundary conditions for atmosphere grid
[667]	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	!
[709]	820	!-- Bilinear Interpolation from atmosphere grid-layer to ocean grid-layer
[667]	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
[709]	826	fl = myl*jj + total_2d_a(j,i)
	827	fr = myr*jj + total_2d_a(j,i+1)
[667]	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	!
[709]	835	!-- Cyclic boundary conditions for ocean grid
[667]	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
[880]	849	#endif
	850
[667]	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 |