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

Last change on this file since 3049 was 3049, checked in by Giersch, 3 years ago

Revision history corrected

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