Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |