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

Last change on this file since 2868 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
Line 
1!> @file surface_coupler.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
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.
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!
17! Copyright 1997-2018 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: surface_coupler.f90 2718 2018-01-02 08:49:38Z hellstea $
27! Corrected "Former revisions" section
28!
29! 2696 2017-12-14 17:12:51Z kanani
30! Change in file header (GPL part)
31!
32! 2233 2017-05-30 18:08:54Z suehring
33!
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!
38! 2031 2016-10-21 15:11:58Z knoop
39! renamed variable rho to rho_ocean
40!
41! 2000 2016-08-20 18:09:15Z knoop
42! Forced header and separation lines into 80 columns
43!
44! 1682 2015-10-07 23:56:08Z knoop
45! Code annotations made doxygen readable
46!
47! 1427 2014-07-07 14:04:59Z maronga
48! Bugfix: value of l_v corrected.
49!
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!
54! 1353 2014-04-08 15:21:23Z heinze
55! REAL constants provided with KIND-attribute
56!
57! 1324 2014-03-21 09:13:16Z suehring
58! Bugfix: ONLY statement for module pegrid removed
59!
60! 1322 2014-03-20 16:38:49Z raasch
61! REAL constants defined as wp-kind
62!
63! 1320 2014-03-20 08:40:49Z raasch
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
71!
72! 1318 2014-03-17 13:35:16Z raasch
73! module interfaces removed
74!
75! 1092 2013-02-02 11:24:22Z raasch
76! unused variables removed
77!
78! 1036 2012-10-22 13:43:42Z raasch
79! code put under GPL (PALM 3.9)
80!
81! 880 2012-04-13 06:28:59Z raasch
82! Bugfix: preprocessor statements for parallel execution added
83!
84! 109 2007-08-28 15:26:47Z letzel
85! Initial revision
86!
87! Description:
88! ------------
89!> Data exchange at the interface between coupled models
90!------------------------------------------------------------------------------!
91 SUBROUTINE surface_coupler
92 
93
94    USE arrays_3d,                                                             &
95        ONLY:  pt, rho_ocean, sa, total_2d_a, total_2d_o, u, v
96
97    USE cloud_parameters,                                                      &
98        ONLY:  cp, l_v
99
100    USE control_parameters,                                                    &
101        ONLY:  coupling_mode, coupling_mode_remote, coupling_topology,         &
102               humidity, humidity_remote, land_surface, message_string,        &
103               terminate_coupled, terminate_coupled_remote,                    &
104               time_since_reference_point, urban_surface
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
115    USE pegrid
116
117    USE surface_mod,                                                           &
118        ONLY :  surf_def_h, surf_lsm_h, surf_type, surf_usm_h
119
120    IMPLICIT NONE
121
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
127    REAL(wp)    ::  time_since_reference_point_rem        !<
128    REAL(wp)    ::  total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !<
129
130    REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  surface_flux !< dummy array for surface fluxes on 2D grid
131
132
133#if defined( __parallel )
134
135    CALL cpu_log( log_point(39), 'surface_coupler', 'start' )
136
137
138
139!
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.
146
147    IF ( coupling_topology == 0 ) THEN
148       CALL MPI_SENDRECV( terminate_coupled,        1, MPI_INTEGER, target_id, &
149                          0,                                                   &
150                          terminate_coupled_remote, 1, MPI_INTEGER, target_id, &
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
160       CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
161                       ierr )
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
168    IF ( terminate_coupled_remote > 0 )  THEN
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 = ',                  &
177                                   terminate_coupled
178       CALL message( 'surface_coupler', 'PA0310', 1, 2, 0, 6, 0 )
179       RETURN
180    ENDIF
181 
182
183!
184!-- Exchange the current simulated time between the models,
185!-- currently just for total_2d
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 )
192    ELSE
193
194       IF ( myid == 0 ) THEN
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,        &
199                         target_id, 11, comm_inter, status, ierr )
200
201       ENDIF
202
203       CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
204                       ierr )
205
206    ENDIF
207
208!
209!-- Exchange the interface data
210    IF ( coupling_mode == 'atmosphere_to_ocean' )  THEN
211   
212!
213!--    Horizontal grid size and number of processors is equal in ocean and
214!--    atmosphere
215       IF ( coupling_topology == 0 )  THEN
216
217!
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 )
224!
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 )
229          IF ( humidity )  THEN
230             CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL,         &
231                            target_id, 13, comm_inter, ierr )
232          ENDIF
233!
234!--       Receive temperature at the bottom surface from the ocean
235          CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14,           &
236                         comm_inter, status, ierr )
237!
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 )
244!
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 )
251!
252!--       Receive u at the bottom surface from the ocean
253          CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17,            &
254                         comm_inter, status, ierr )
255!
256!--       Receive v at the bottom surface from the ocean
257          CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18,            &
258                         comm_inter, status, ierr )
259!
260!--    Horizontal grid size or number of processors differs between
261!--    ocean and atmosphere
262       ELSE
263     
264!
265!--       Send heat flux at bottom surface to the ocean
266          total_2d_a = 0.0_wp
267          total_2d   = 0.0_wp
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 )
272
273          CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0,  &
274                           comm2d, ierr )
275          CALL interpolate_to_ocean( 12 )   
276!
277!--       Send humidity flux at bottom surface to the ocean
278          IF ( humidity )  THEN
279             total_2d_a = 0.0_wp
280             total_2d   = 0.0_wp
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 )
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 )
290          ENDIF
291!
292!--       Receive temperature at the bottom surface from the ocean
293          IF ( myid == 0 )  THEN
294             CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL,          &
295                            target_id, 14, comm_inter, status, ierr )   
296          ENDIF
297          CALL MPI_BARRIER( comm2d, ierr )
298          CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
299                          ierr )
300          pt(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
301!
302!--       Send momentum flux (u) at bottom surface to the ocean
303          total_2d_a = 0.0_wp 
304          total_2d   = 0.0_wp
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 )
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 )
312!
313!--       Send momentum flux (v) at bottom surface to the ocean
314          total_2d_a = 0.0_wp
315          total_2d   = 0.0_wp
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 )
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 )
323!
324!--       Receive u at the bottom surface from the ocean
325          IF ( myid == 0 )  THEN
326             CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
327                            target_id, 17, comm_inter, status, ierr )
328          ENDIF
329          CALL MPI_BARRIER( comm2d, ierr )
330          CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
331                          ierr )
332          u(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
333!
334!--       Receive v at the bottom surface from the ocean
335          IF ( myid == 0 )  THEN
336             CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
337                            target_id, 18, comm_inter, status, ierr )
338          ENDIF
339          CALL MPI_BARRIER( comm2d, ierr )
340          CALL MPI_BCAST( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, 0, comm2d, &
341                          ierr )
342          v(0,nysg:nyng,nxlg:nxrg) = total_2d_a(nysg:nyng,nxlg:nxrg)
343
344       ENDIF
345
346    ELSEIF ( coupling_mode == 'ocean_to_atmosphere' )  THEN
347
348!
349!--    Horizontal grid size and number of processors is equal
350!--    in ocean and atmosphere
351       IF ( coupling_topology == 0 ) THEN
352!
353!--       Receive heat flux at the sea surface (top) from the atmosphere
354          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
355                         comm_inter, status, ierr )
356          CALL transfer_2D_to_1D_equal( surf_def_h(2)%shf )
357!
358!--       Receive humidity flux from the atmosphere (bottom)
359!--       and add it to the heat flux at the sea surface (top)...
360          IF ( humidity_remote )  THEN
361             CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
362                            target_id, 13, comm_inter, status, ierr )
363             CALL transfer_2D_to_1D_equal( surf_def_h(2)%qsws )
364          ENDIF
365!
366!--       Send sea surface temperature to the atmosphere model
367          CALL MPI_SEND( pt(nzt,nysg,nxlg), 1, type_xy, target_id, 14, &
368                         comm_inter, ierr )
369!
370!--       Receive momentum flux (u) at the sea surface (top) from the atmosphere
371          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
372                         comm_inter, status, ierr )
373          CALL transfer_2D_to_1D_equal( surf_def_h(2)%usws )
374!
375!--       Receive momentum flux (v) at the sea surface (top) from the atmosphere
376          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
377                         comm_inter, status, ierr )
378          CALL transfer_2D_to_1D_equal( surf_def_h(2)%vsws )
379!
380!--       Send u to the atmosphere
381          CALL MPI_SEND( u(nzt,nysg,nxlg), 1, type_xy, target_id, 17, &
382                         comm_inter, ierr )
383!
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!
388!--    Horizontal gridsize or number of processors differs between
389!--    ocean and atmosphere
390       ELSE
391!
392!--       Receive heat flux at the sea surface (top) from the atmosphere
393          IF ( myid == 0 )  THEN
394             CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
395                            target_id, 12, comm_inter, status, ierr )
396          ENDIF
397          CALL MPI_BARRIER( comm2d, ierr )
398          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
399                          ierr )
400          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%shf )
401!
402!--       Receive humidity flux at the sea surface (top) from the atmosphere
403          IF ( humidity_remote )  THEN
404             IF ( myid == 0 )  THEN
405                CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
406                               target_id, 13, comm_inter, status, ierr )
407             ENDIF
408             CALL MPI_BARRIER( comm2d, ierr )
409             CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
410                             comm2d, ierr)
411             CALL transfer_2D_to_1D_unequal( surf_def_h(2)%qsws )
412          ENDIF
413!
414!--       Send surface temperature to atmosphere
415          total_2d_o = 0.0_wp
416          total_2d   = 0.0_wp
417          total_2d(nys:nyn,nxl:nxr) = pt(nzt,nys:nyn,nxl:nxr)
418
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 )
422!
423!--       Receive momentum flux (u) at the sea surface (top) from the atmosphere
424          IF ( myid == 0 )  THEN
425             CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
426                            target_id, 15, comm_inter, status, ierr )
427          ENDIF
428          CALL MPI_BARRIER( comm2d, ierr )
429          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
430                          0, comm2d, ierr )
431          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%usws )
432!
433!--       Receive momentum flux (v) at the sea surface (top) from the atmosphere
434          IF ( myid == 0 )  THEN
435             CALL MPI_RECV( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
436                            target_id, 16, comm_inter, status, ierr )
437          ENDIF
438          CALL MPI_BARRIER( comm2d, ierr )
439          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
440                          ierr )
441          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%vsws )
442!
443!--       Send u to atmosphere
444          total_2d_o = 0.0_wp 
445          total_2d   = 0.0_wp
446          total_2d(nys:nyn,nxl:nxr) = u(nzt,nys:nyn,nxl:nxr)
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 )
450!
451!--       Send v to atmosphere
452          total_2d_o = 0.0_wp
453          total_2d   = 0.0_wp
454          total_2d(nys:nyn,nxl:nxr) = v(nzt,nys:nyn,nxl:nxr)
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 )
458       
459       ENDIF
460
461!
462!--    Conversions of fluxes received from atmosphere
463       IF ( humidity_remote )  THEN
464!
465!--       Here top heat flux is still the sum of atmospheric bottom heat fluxes,
466!--       * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
467!--       /(rho_atm(=1.0)*c_p)
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
474!
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
484       ENDIF
485
486!
487!--    Adjust the kinematic heat flux with respect to ocean density
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
495
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
499
500    ENDIF
501
502    IF ( coupling_topology == 1 )  THEN
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
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  END SUBROUTINE surface_coupler
668
669
670
671!------------------------------------------------------------------------------!
672! Description:
673! ------------
674!> @todo Missing subroutine description.
675!------------------------------------------------------------------------------!
676  SUBROUTINE interpolate_to_atmos( tag )
677
678#if defined( __parallel )
679
680    USE arrays_3d,                                                             &
681        ONLY:  total_2d_a, total_2d_o
682
683    USE indices,                                                               &
684        ONLY:  nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
685
686    USE kinds
687
688    USE pegrid
689
690    IMPLICIT NONE
691
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   !<
700
701    INTEGER(iwp), intent(in) ::  tag !<
702
703    CALL MPI_BARRIER( comm2d, ierr )
704
705    IF ( myid == 0 )  THEN
706!
707!--    Cyclic boundary conditions for the total 2D-grid
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
714!
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) 
718
719!
720!--    Distance for interpolation around coarse grid points within the fine
721!--    grid (note: 2*dnx2 must not be equal with dnx)
722       dnx2 = 2 * ( dnx / 2 )
723       dny2 = 2 * ( dny / 2 )
724
725       total_2d_a = 0.0_wp
726!
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(j*dny+jj,i*dnx+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!
740!--    Cyclic boundary conditions for atmosphere grid
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
748       CALL MPI_SEND( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, target_id, &
749                      tag, comm_inter, ierr )
750
751    ENDIF
752
753    CALL MPI_BARRIER( comm2d, ierr )
754
755#endif
756
757  END SUBROUTINE interpolate_to_atmos
758
759
760!------------------------------------------------------------------------------!
761! Description:
762! ------------
763!> @todo Missing subroutine description.
764!------------------------------------------------------------------------------!
765  SUBROUTINE interpolate_to_ocean( tag )
766
767#if defined( __parallel )
768
769    USE arrays_3d,                                                             &
770        ONLY:  total_2d_a, total_2d_o
771
772    USE indices,                                                               &
773        ONLY:  nbgp, nx, nx_a, nx_o, ny, ny_a, ny_o
774
775    USE kinds
776
777    USE pegrid
778
779    IMPLICIT NONE
780
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 !<
788
789    REAL(wp)                 ::  fl  !<
790    REAL(wp)                 ::  fr  !<
791    REAL(wp)                 ::  myl !<
792    REAL(wp)                 ::  myr !<
793
794    CALL MPI_BARRIER( comm2d, ierr )
795
796    IF ( myid == 0 )  THEN   
797
798!
799!--    Number of gridpoints of the fine grid within one mesh of the coarse grid
800       dnx = ( nx_o + 1 ) / ( nx_a + 1 ) 
801       dny = ( ny_o + 1 ) / ( ny_a + 1 ) 
802
803!
804!--    Cyclic boundary conditions for atmosphere grid
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!
811!--    Bilinear Interpolation from atmosphere grid-layer to ocean grid-layer
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
817                fl = myl*jj + total_2d_a(j,i) 
818                fr = myr*jj + total_2d_a(j,i+1) 
819                DO  ii = 0, dnx-1
820                   total_2d_o(j*dny+jj,i*dnx+ii) = ( fr - fl ) / dnx * ii + fl
821                ENDDO
822             ENDDO
823          ENDDO
824       ENDDO
825!
826!--    Cyclic boundary conditions for ocean grid
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
840#endif
841
842  END SUBROUTINE interpolate_to_ocean
Note: See TracBrowser for help on using the repository browser.