Home

Context Navigation

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

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |