Home

Context Navigation

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

Last change on this file since 1418 was 1418, checked in by fricke, 10 years ago
Bugfixes concerning grid stretching for the ocean and calculation of the salinity flux in routine surface_coupler
Property svn:keywords set to `Id`
File size: 21.5 KB

Rev	Line
[102]	1	SUBROUTINE surface_coupler
	2
[1036]	3	!--------------------------------------------------------------------------------!
	4	! This file is part of PALM.
	5	!
	6	! PALM is free software: you can redistribute it and/or modify it under the terms
	7	! of the GNU General Public License as published by the Free Software Foundation,
	8	! either version 3 of the License, or (at your option) any later version.
	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	!
[1310]	17	! Copyright 1997-2014 Leibniz Universitaet Hannover
[1036]	18	!--------------------------------------------------------------------------------!
	19	!
[258]	20	! Current revisions:
[1092]	21	! ------------------
[1418]	22	! Bugfix: For caluclation of the salinity flux at the sea surface,
	23	! the given value for salinity must be in percent and not in psu
[1321]	24	!
	25	! Former revisions:
	26	! -----------------
	27	! $Id: surface_coupler.f90 1418 2014-06-06 13:05:08Z fricke $
	28	!
[1354]	29	! 1353 2014-04-08 15:21:23Z heinze
	30	! REAL constants provided with KIND-attribute
	31	!
[1325]	32	! 1324 2014-03-21 09:13:16Z suehring
	33	! Bugfix: ONLY statement for module pegrid removed
	34	!
[1323]	35	! 1322 2014-03-20 16:38:49Z raasch
	36	! REAL constants defined as wp-kind
	37	!
[1321]	38	! 1320 2014-03-20 08:40:49Z raasch
[1320]	39	! ONLY-attribute added to USE-statements,
	40	! kind-parameters added to all INTEGER and REAL declaration statements,
	41	! kinds are defined in new module kinds,
	42	! old module precision_kind is removed,
	43	! revision history before 2012 removed,
	44	! comment fields (!:) to be used for variable explanations added to
	45	! all variable declaration statements
[102]	46	!
[1319]	47	! 1318 2014-03-17 13:35:16Z raasch
	48	! module interfaces removed
	49	!
[1093]	50	! 1092 2013-02-02 11:24:22Z raasch
	51	! unused variables removed
	52	!
[1037]	53	! 1036 2012-10-22 13:43:42Z raasch
	54	! code put under GPL (PALM 3.9)
	55	!
[881]	56	! 880 2012-04-13 06:28:59Z raasch
	57	! Bugfix: preprocessor statements for parallel execution added
	58	!
[110]	59	! 109 2007-08-28 15:26:47Z letzel
[102]	60	! Initial revision
	61	!
	62	! Description:
	63	! ------------
	64	! Data exchange at the interface between coupled models
	65	!------------------------------------------------------------------------------!
	66
[1320]	67	USE arrays_3d, &
	68	ONLY: pt, shf, qsws, qswst_remote, rho, sa, saswst, total_2d_a, &
	69	total_2d_o, tswst, u, usws, uswst, v, vsws, vswst
	70
	71	USE control_parameters, &
	72	ONLY: coupling_mode, coupling_mode_remote, coupling_topology, &
	73	humidity, humidity_remote, message_string, terminate_coupled, &
	74	terminate_coupled_remote, time_since_reference_point
	75
	76	USE cpulog, &
	77	ONLY: cpu_log, log_point
	78
	79	USE indices, &
	80	ONLY: nbgp, nx, nxl, nxlg, nxr, nxrg, nx_a, nx_o, ny, nyn, nyng, nys, &
	81	nysg, ny_a, ny_o, nzt
	82
	83	USE kinds
	84
[102]	85	USE pegrid
	86
	87	IMPLICIT NONE
	88
[1320]	89	REAL(wp) :: time_since_reference_point_rem !:
	90	REAL(wp) :: total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !:
[102]	91
[206]	92	#if defined( __parallel )
[102]	93
[667]	94	CALL cpu_log( log_point(39), 'surface_coupler', 'start' )
[102]	95
[667]	96
	97
[102]	98	!
[108]	99	!-- In case of model termination initiated by the remote model
	100	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
	101	!-- The rest of the coupler must then be skipped because it would cause an MPI
	102	!-- intercomminucation hang.
	103	!-- If necessary, the coupler will be called at the beginning of the next
	104	!-- restart run.
[667]	105
	106	IF ( coupling_topology == 0 ) THEN
[709]	107	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, target_id, &
	108	0, &
	109	terminate_coupled_remote, 1, MPI_INTEGER, target_id, &
[667]	110	0, comm_inter, status, ierr )
	111	ELSE
	112	IF ( myid == 0) THEN
	113	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
	114	target_id, 0, &
	115	terminate_coupled_remote, 1, MPI_INTEGER, &
	116	target_id, 0, &
	117	comm_inter, status, ierr )
	118	ENDIF
[709]	119	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
	120	ierr )
[667]	121
	122	ALLOCATE( total_2d_a(-nbgp:ny_a+nbgp,-nbgp:nx_a+nbgp), &
	123	total_2d_o(-nbgp:ny_o+nbgp,-nbgp:nx_o+nbgp) )
	124
	125	ENDIF
	126
[108]	127	IF ( terminate_coupled_remote > 0 ) THEN
[274]	128	WRITE( message_string, * ) 'remote model "', &
	129	TRIM( coupling_mode_remote ), &
	130	'" terminated', &
	131	'&with terminate_coupled_remote = ', &
	132	terminate_coupled_remote, &
	133	'&local model "', TRIM( coupling_mode ), &
	134	'" has', &
	135	'&terminate_coupled = ', &
[667]	136	terminate_coupled
[258]	137	CALL message( 'surface_coupler', 'PA0310', 1, 2, 0, 6, 0 )
[108]	138	RETURN
	139	ENDIF
[667]	140
[291]	141
[108]	142	!
	143	!-- Exchange the current simulated time between the models,
[667]	144	!-- currently just for total_2ding
[709]	145	IF ( coupling_topology == 0 ) THEN
	146
	147	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, 11, &
	148	comm_inter, ierr )
	149	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, target_id, &
	150	11, comm_inter, status, ierr )
[667]	151	ELSE
[709]	152
[667]	153	IF ( myid == 0 ) THEN
[709]	154
	155	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
	156	11, comm_inter, ierr )
	157	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
[667]	158	target_id, 11, comm_inter, status, ierr )
[709]	159
[667]	160	ENDIF
[709]	161
	162	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
	163	ierr )
	164
[667]	165	ENDIF
[102]	166
	167	!
	168	!-- Exchange the interface data
	169	IF ( coupling_mode == 'atmosphere_to_ocean' ) THEN
[667]	170
	171	!
[709]	172	!-- Horizontal grid size and number of processors is equal in ocean and
	173	!-- atmosphere
	174	IF ( coupling_topology == 0 ) THEN
[102]	175
	176	!
[709]	177	!-- Send heat flux at bottom surface to the ocean
	178	CALL MPI_SEND( shf(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
	179	comm_inter, ierr )
[102]	180	!
[709]	181	!-- Send humidity flux at bottom surface to the ocean
[667]	182	IF ( humidity ) THEN
[709]	183	CALL MPI_SEND( qsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 13, &
	184	comm_inter, ierr )
[667]	185	ENDIF
	186	!
[709]	187	!-- Receive temperature at the bottom surface from the ocean
	188	CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14, &
	189	comm_inter, status, ierr )
[108]	190	!
[709]	191	!-- Send the momentum flux (u) at bottom surface to the ocean
	192	CALL MPI_SEND( usws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
	193	comm_inter, ierr )
[102]	194	!
[709]	195	!-- Send the momentum flux (v) at bottom surface to the ocean
	196	CALL MPI_SEND( vsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
	197	comm_inter, ierr )
[102]	198	!
[709]	199	!-- Receive u at the bottom surface from the ocean
	200	CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17, &
	201	comm_inter, status, ierr )
[667]	202	!
[709]	203	!-- Receive v at the bottom surface from the ocean
	204	CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18, &
	205	comm_inter, status, ierr )
[667]	206	!
	207	!-- Horizontal grid size or number of processors differs between
	208	!-- ocean and atmosphere
	209	ELSE
	210
	211	!
[709]	212	!-- Send heat flux at bottom surface to the ocean
[1353]	213	total_2d_a = 0.0_wp
	214	total_2d = 0.0_wp
[667]	215	total_2d(nys:nyn,nxl:nxr) = shf(nys:nyn,nxl:nxr)
[709]	216
	217	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
	218	comm2d, ierr )
	219	CALL interpolate_to_ocean( 12 )
[667]	220	!
[709]	221	!-- Send humidity flux at bottom surface to the ocean
	222	IF ( humidity ) THEN
[1353]	223	total_2d_a = 0.0_wp
	224	total_2d = 0.0_wp
[667]	225	total_2d(nys:nyn,nxl:nxr) = qsws(nys:nyn,nxl:nxr)
[709]	226
	227	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, &
	228	0, comm2d, ierr )
	229	CALL interpolate_to_ocean( 13 )
[667]	230	ENDIF
	231	!
[709]	232	!-- Receive temperature at the bottom surface from the ocean
	233	IF ( myid == 0 ) THEN
[667]	234	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
	235	target_id, 14, comm_inter, status, ierr )
	236	ENDIF
	237	CALL MPI_BARRIER( comm2d, ierr )
[709]	238	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	239	ierr )
[667]	240	pt(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	241	!
[709]	242	!-- Send momentum flux (u) at bottom surface to the ocean
[1353]	243	total_2d_a = 0.0_wp
	244	total_2d = 0.0_wp
[667]	245	total_2d(nys:nyn,nxl:nxr) = usws(nys:nyn,nxl:nxr)
[709]	246	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
	247	comm2d, ierr )
	248	CALL interpolate_to_ocean( 15 )
[667]	249	!
[709]	250	!-- Send momentum flux (v) at bottom surface to the ocean
[1353]	251	total_2d_a = 0.0_wp
	252	total_2d = 0.0_wp
[667]	253	total_2d(nys:nyn,nxl:nxr) = vsws(nys:nyn,nxl:nxr)
[709]	254	CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
	255	comm2d, ierr )
	256	CALL interpolate_to_ocean( 16 )
[667]	257	!
[709]	258	!-- Receive u at the bottom surface from the ocean
	259	IF ( myid == 0 ) THEN
[667]	260	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
[709]	261	target_id, 17, comm_inter, status, ierr )
[667]	262	ENDIF
	263	CALL MPI_BARRIER( comm2d, ierr )
[709]	264	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	265	ierr )
[667]	266	u(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	267	!
[709]	268	!-- Receive v at the bottom surface from the ocean
	269	IF ( myid == 0 ) THEN
[667]	270	CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
[709]	271	target_id, 18, comm_inter, status, ierr )
[667]	272	ENDIF
	273	CALL MPI_BARRIER( comm2d, ierr )
[709]	274	CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
	275	ierr )
[667]	276	v(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
	277
	278	ENDIF
	279
[102]	280	ELSEIF ( coupling_mode == 'ocean_to_atmosphere' ) THEN
	281
	282	!
[667]	283	!-- Horizontal grid size and number of processors is equal
	284	!-- in ocean and atmosphere
	285	IF ( coupling_topology == 0 ) THEN
	286	!
[709]	287	!-- Receive heat flux at the sea surface (top) from the atmosphere
	288	CALL MPI_RECV( tswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
	289	comm_inter, status, ierr )
[102]	290	!
[709]	291	!-- Receive humidity flux from the atmosphere (bottom)
[667]	292	!-- and add it to the heat flux at the sea surface (top)...
	293	IF ( humidity_remote ) THEN
	294	CALL MPI_RECV( qswst_remote(nysg,nxlg), ngp_xy, MPI_REAL, &
	295	target_id, 13, comm_inter, status, ierr )
	296	ENDIF
	297	!
	298	!-- Send sea surface temperature to the atmosphere model
[709]	299	CALL MPI_SEND( pt(nzt,nysg,nxlg), 1, type_xy, target_id, 14, &
	300	comm_inter, ierr )
[667]	301	!
	302	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
[709]	303	CALL MPI_RECV( uswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
	304	comm_inter, status, ierr )
[667]	305	!
	306	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
[709]	307	CALL MPI_RECV( vswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
	308	comm_inter, status, ierr )
[667]	309	!
[709]	310	!-- Send u to the atmosphere
	311	CALL MPI_SEND( u(nzt,nysg,nxlg), 1, type_xy, target_id, 17, &
	312	comm_inter, ierr )
[667]	313	!
[709]	314	!-- Send v to the atmosphere
	315	CALL MPI_SEND( v(nzt,nysg,nxlg), 1, type_xy, target_id, 18, &
	316	comm_inter, ierr )
	317	!
[667]	318	!-- Horizontal gridsize or number of processors differs between
	319	!-- ocean and atmosphere
	320	ELSE
	321	!
[709]	322	!-- Receive heat flux at the sea surface (top) from the atmosphere
	323	IF ( myid == 0 ) THEN
[667]	324	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	325	target_id, 12, comm_inter, status, ierr )
[667]	326	ENDIF
	327	CALL MPI_BARRIER( comm2d, ierr )
[709]	328	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
	329	ierr )
[667]	330	tswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
	331	!
[709]	332	!-- Receive humidity flux at the sea surface (top) from the atmosphere
	333	IF ( humidity_remote ) THEN
	334	IF ( myid == 0 ) THEN
[667]	335	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	336	target_id, 13, comm_inter, status, ierr )
[667]	337	ENDIF
	338	CALL MPI_BARRIER( comm2d, ierr )
[709]	339	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
	340	comm2d, ierr)
[667]	341	qswst_remote(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
	342	ENDIF
	343	!
	344	!-- Send surface temperature to atmosphere
[1353]	345	total_2d_o = 0.0_wp
	346	total_2d = 0.0_wp
[667]	347	total_2d(nys:nyn,nxl:nxr) = pt(nzt,nys:nyn,nxl:nxr)
	348
[709]	349	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
	350	comm2d, ierr)
	351	CALL interpolate_to_atmos( 14 )
[667]	352	!
[709]	353	!-- Receive momentum flux (u) at the sea surface (top) from the atmosphere
	354	IF ( myid == 0 ) THEN
[667]	355	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	356	target_id, 15, comm_inter, status, ierr )
[667]	357	ENDIF
	358	CALL MPI_BARRIER( comm2d, ierr )
	359	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	360	0, comm2d, ierr )
[667]	361	uswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
	362	!
[709]	363	!-- Receive momentum flux (v) at the sea surface (top) from the atmosphere
	364	IF ( myid == 0 ) THEN
[667]	365	CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
[709]	366	target_id, 16, comm_inter, status, ierr )
[667]	367	ENDIF
	368	CALL MPI_BARRIER( comm2d, ierr )
[709]	369	CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
	370	ierr )
[667]	371	vswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
	372	!
	373	!-- Send u to atmosphere
[1353]	374	total_2d_o = 0.0_wp
	375	total_2d = 0.0_wp
[667]	376	total_2d(nys:nyn,nxl:nxr) = u(nzt,nys:nyn,nxl:nxr)
[709]	377	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
	378	comm2d, ierr )
	379	CALL interpolate_to_atmos( 17 )
[667]	380	!
	381	!-- Send v to atmosphere
[1353]	382	total_2d_o = 0.0_wp
	383	total_2d = 0.0_wp
[667]	384	total_2d(nys:nyn,nxl:nxr) = v(nzt,nys:nyn,nxl:nxr)
[709]	385	CALL MPI_REDUCE( total_2d, total_2d_o, ngp_o, MPI_REAL, MPI_SUM, 0, &
	386	comm2d, ierr )
	387	CALL interpolate_to_atmos( 18 )
[667]	388
	389	ENDIF
	390
	391	!
	392	!-- Conversions of fluxes received from atmosphere
	393	IF ( humidity_remote ) THEN
[108]	394	!
[709]	395	!-- Here tswst is still the sum of atmospheric bottom heat fluxes,
	396	!-- * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
	397	!-- /(rho_atm(=1.0)*c_p)
[1322]	398	tswst = tswst + qswst_remote * 2.2626108E6_wp / 1005.0_wp
[709]	399	!
[667]	400	!-- ...and convert it to a salinity flux at the sea surface (top)
[108]	401	!-- following Steinhorn (1991), JPO 21, pp. 1681-1683:
	402	!-- S'w' = -S * evaporation / ( rho_water * ( 1 - S ) )
[1418]	403	saswst = -1.0_wp * sa(nzt,:,:) * 0.001 * qswst_remote / &
	404	( rho(nzt,:,:) * ( 1.0_wp - sa(nzt,:,:) * 0.001 ) )
[108]	405	ENDIF
	406
	407	!
[102]	408	!-- Adjust the kinematic heat flux with respect to ocean density
	409	!-- (constants are the specific heat capacities for air and water)
[667]	410	!-- now tswst is the ocean top heat flux
[1322]	411	tswst = tswst / rho(nzt,:,:) * 1005.0_wp / 4218.0_wp
[102]	412
	413	!
[667]	414	!-- Adjust the momentum fluxes with respect to ocean density
	415	uswst = uswst / rho(nzt,:,:)
	416	vswst = vswst / rho(nzt,:,:)
[102]	417
[667]	418	ENDIF
	419
[709]	420	IF ( coupling_topology == 1 ) THEN
[667]	421	DEALLOCATE( total_2d_o, total_2d_a )
	422	ENDIF
	423
	424	CALL cpu_log( log_point(39), 'surface_coupler', 'stop' )
	425
	426	#endif
	427
	428	END SUBROUTINE surface_coupler
	429
	430
	431
[709]	432	SUBROUTINE interpolate_to_atmos( tag )
[667]	433
[880]	434	#if defined( __parallel )
	435
[1320]	436	USE arrays_3d, &
	437	ONLY: total_2d_a, total_2d_o
[667]	438
[1320]	439	USE indices, &
	440	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
	441
	442	USE kinds
	443
[1324]	444	USE pegrid
[1320]	445
[667]	446	IMPLICIT NONE
	447
[1320]	448	INTEGER(iwp) :: dnx !:
	449	INTEGER(iwp) :: dnx2 !:
	450	INTEGER(iwp) :: dny !:
	451	INTEGER(iwp) :: dny2 !:
	452	INTEGER(iwp) :: i !:
	453	INTEGER(iwp) :: ii !:
	454	INTEGER(iwp) :: j !:
	455	INTEGER(iwp) :: jj !:
[667]	456
[1320]	457	INTEGER(iwp), intent(in) :: tag !:
	458
[667]	459	CALL MPI_BARRIER( comm2d, ierr )
	460
[709]	461	IF ( myid == 0 ) THEN
	462	!
	463	!-- Cyclic boundary conditions for the total 2D-grid
[667]	464	total_2d_o(-nbgp:-1,:) = total_2d_o(ny+1-nbgp:ny,:)
	465	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx+1-nbgp:nx)
	466
	467	total_2d_o(ny+1:ny+nbgp,:) = total_2d_o(0:nbgp-1,:)
	468	total_2d_o(:,nx+1:nx+nbgp) = total_2d_o(:,0:nbgp-1)
	469
[102]	470	!
[667]	471	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
	472	dnx = (nx_o+1) / (nx_a+1)
	473	dny = (ny_o+1) / (ny_a+1)
[102]	474
	475	!
[709]	476	!-- Distance for interpolation around coarse grid points within the fine
	477	!-- grid (note: 2*dnx2 must not be equal with dnx)
[667]	478	dnx2 = 2 * ( dnx / 2 )
	479	dny2 = 2 * ( dny / 2 )
[102]	480
[1353]	481	total_2d_a = 0.0_wp
[102]	482	!
[667]	483	!-- Interpolation from ocean-grid-layer to atmosphere-grid-layer
	484	DO j = 0, ny_a
	485	DO i = 0, nx_a
	486	DO jj = 0, dny2
	487	DO ii = 0, dnx2
	488	total_2d_a(j,i) = total_2d_a(j,i) &
	489	+ total_2d_o(jdny+jj,idnx+ii)
	490	ENDDO
	491	ENDDO
	492	total_2d_a(j,i) = total_2d_a(j,i) / ( ( dnx2 + 1 ) * ( dny2 + 1 ) )
	493	ENDDO
	494	ENDDO
	495	!
[709]	496	!-- Cyclic boundary conditions for atmosphere grid
[667]	497	total_2d_a(-nbgp:-1,:) = total_2d_a(ny_a+1-nbgp:ny_a,:)
	498	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx_a+1-nbgp:nx_a)
	499
	500	total_2d_a(ny_a+1:ny_a+nbgp,:) = total_2d_a(0:nbgp-1,:)
	501	total_2d_a(:,nx_a+1:nx_a+nbgp) = total_2d_a(:,0:nbgp-1)
	502	!
	503	!-- Transfer of the atmosphere-grid-layer to the atmosphere
[709]	504	CALL MPI_SEND( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, target_id, &
	505	tag, comm_inter, ierr )
[102]	506
	507	ENDIF
	508
[667]	509	CALL MPI_BARRIER( comm2d, ierr )
[102]	510
[880]	511	#endif
	512
[667]	513	END SUBROUTINE interpolate_to_atmos
[102]	514
[667]	515
[709]	516	SUBROUTINE interpolate_to_ocean( tag )
[667]	517
[880]	518	#if defined( __parallel )
	519
[1320]	520	USE arrays_3d, &
	521	ONLY: total_2d_a, total_2d_o
[667]	522
[1320]	523	USE indices, &
	524	ONLY: nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
	525
	526	USE kinds
	527
[1324]	528	USE pegrid
[1320]	529
[667]	530	IMPLICIT NONE
	531
[1320]	532	INTEGER(iwp) :: dnx !:
	533	INTEGER(iwp) :: dny !:
	534	INTEGER(iwp) :: i !:
	535	INTEGER(iwp) :: ii !:
	536	INTEGER(iwp) :: j !:
	537	INTEGER(iwp) :: jj !:
	538	INTEGER(iwp), intent(in) :: tag !:
[667]	539
[1320]	540	REAL(wp) :: fl !:
	541	REAL(wp) :: fr !:
	542	REAL(wp) :: myl !:
	543	REAL(wp) :: myr !:
[709]	544
[667]	545	CALL MPI_BARRIER( comm2d, ierr )
	546
[709]	547	IF ( myid == 0 ) THEN
[667]	548
	549	!
[709]	550	!-- Number of gridpoints of the fine grid within one mesh of the coarse grid
[667]	551	dnx = ( nx_o + 1 ) / ( nx_a + 1 )
	552	dny = ( ny_o + 1 ) / ( ny_a + 1 )
	553
	554	!
[709]	555	!-- Cyclic boundary conditions for atmosphere grid
[667]	556	total_2d_a(-nbgp:-1,:) = total_2d_a(ny+1-nbgp:ny,:)
	557	total_2d_a(:,-nbgp:-1) = total_2d_a(:,nx+1-nbgp:nx)
	558
	559	total_2d_a(ny+1:ny+nbgp,:) = total_2d_a(0:nbgp-1,:)
	560	total_2d_a(:,nx+1:nx+nbgp) = total_2d_a(:,0:nbgp-1)
	561	!
[709]	562	!-- Bilinear Interpolation from atmosphere grid-layer to ocean grid-layer
[667]	563	DO j = 0, ny
	564	DO i = 0, nx
	565	myl = ( total_2d_a(j+1,i) - total_2d_a(j,i) ) / dny
	566	myr = ( total_2d_a(j+1,i+1) - total_2d_a(j,i+1) ) / dny
	567	DO jj = 0, dny-1
[709]	568	fl = myl*jj + total_2d_a(j,i)
	569	fr = myr*jj + total_2d_a(j,i+1)
[667]	570	DO ii = 0, dnx-1
	571	total_2d_o(jdny+jj,idnx+ii) = ( fr - fl ) / dnx * ii + fl
	572	ENDDO
	573	ENDDO
	574	ENDDO
	575	ENDDO
	576	!
[709]	577	!-- Cyclic boundary conditions for ocean grid
[667]	578	total_2d_o(-nbgp:-1,:) = total_2d_o(ny_o+1-nbgp:ny_o,:)
	579	total_2d_o(:,-nbgp:-1) = total_2d_o(:,nx_o+1-nbgp:nx_o)
	580
	581	total_2d_o(ny_o+1:ny_o+nbgp,:) = total_2d_o(0:nbgp-1,:)
	582	total_2d_o(:,nx_o+1:nx_o+nbgp) = total_2d_o(:,0:nbgp-1)
	583
	584	CALL MPI_SEND( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
	585	target_id, tag, comm_inter, ierr )
	586
	587	ENDIF
	588
	589	CALL MPI_BARRIER( comm2d, ierr )
	590
[880]	591	#endif
	592
[667]	593	END SUBROUTINE interpolate_to_ocean

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |