Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |