Ignore:
Timestamp:
May 30, 2017 5:47:52 PM (4 years ago)
Author:
suehring
Message:

Adjustments according new topography and surface-modelling concept implemented

File:
1 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/surface_coupler.f90

    r2101 r2232  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! Adjust to new surface structure. Transfer 1D surface fluxes onto 2D grid
     23! (and back).
    2324!
    2425! Former revisions:
     
    8384
    8485    USE arrays_3d,                                                             &
    85         ONLY:  pt, shf, qsws, qswst_remote, rho_ocean, sa, saswst, total_2d_a,       &
    86                total_2d_o, tswst, u, usws, uswst, v, vsws, vswst
     86        ONLY:  pt, rho_ocean, sa, total_2d_a, total_2d_o, u, v
    8787
    8888    USE cloud_parameters,                                                      &
     
    9191    USE control_parameters,                                                    &
    9292        ONLY:  coupling_mode, coupling_mode_remote, coupling_topology,         &
    93                humidity, humidity_remote, message_string, terminate_coupled,   &
    94                terminate_coupled_remote, time_since_reference_point
     93               humidity, humidity_remote, land_surface, message_string,        &
     94               terminate_coupled, terminate_coupled_remote,                    &
     95               time_since_reference_point, urban_surface
    9596
    9697    USE cpulog,                                                                &
     
    105106    USE pegrid
    106107
     108    USE surface_mod,                                                           &
     109        ONLY :  surf_def_h, surf_lsm_h, surf_type, surf_usm_h
     110
    107111    IMPLICIT NONE
    108112
     113    INTEGER(iwp) ::  i                                    !< index variable x-direction
     114    INTEGER(iwp) ::  j                                    !< index variable y-direction
     115    INTEGER(iwp) ::  m                                    !< running index for surface elements
     116
     117    REAL(wp)    ::  cpw = 4218.0_wp                       !< heat capacity of water at constant pressure
    109118    REAL(wp)    ::  time_since_reference_point_rem        !<
    110119    REAL(wp)    ::  total_2d(-nbgp:ny+nbgp,-nbgp:nx+nbgp) !<
    111120
    112     REAL(wp)    ::  cpw = 4218.0_wp !< heat capacity of water at constant pressure
     121    REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  surface_flux !< dummy array for surface fluxes on 2D grid
     122
    113123
    114124#if defined( __parallel )
     
    164174!
    165175!-- Exchange the current simulated time between the models,
    166 !-- currently just for total_2ding
     176!-- currently just for total_2d
    167177    IF ( coupling_topology == 0 ) THEN
    168178   
     
    197207
    198208!
    199 !--       Send heat flux at bottom surface to the ocean
    200           CALL MPI_SEND( shf(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
    201                          comm_inter, ierr )
    202 !
    203 !--       Send humidity flux at bottom surface to the ocean
     209!--       Send heat flux at bottom surface to the ocean. First, transfer from
     210!--       1D surface type to 2D grid.
     211          CALL transfer_1D_to_2D_equal( surf_def_h(0)%shf, surf_lsm_h%shf,     &
     212                                        surf_usm_h%shf )
     213          CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
     214                         12, comm_inter, ierr )
     215!
     216!--       Send humidity flux at bottom surface to the ocean. First, transfer
     217!--       from 1D surface type to 2D grid.
     218          CALL transfer_1D_to_2D_equal( surf_def_h(0)%qsws, surf_lsm_h%qsws,   &
     219                                        surf_usm_h%qsws )
    204220          IF ( humidity )  THEN
    205              CALL MPI_SEND( qsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 13, &
    206                             comm_inter, ierr )
     221             CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL,        &
     222                            target_id, 13, comm_inter, ierr )
    207223          ENDIF
    208224!
    209225!--       Receive temperature at the bottom surface from the ocean
    210           CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14, &
     226          CALL MPI_RECV( pt(0,nysg,nxlg), 1, type_xy, target_id, 14,           &
    211227                         comm_inter, status, ierr )
    212228!
    213 !--       Send the momentum flux (u) at bottom surface to the ocean
    214           CALL MPI_SEND( usws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
    215                          comm_inter, ierr )
    216 !
    217 !--       Send the momentum flux (v) at bottom surface to the ocean
    218           CALL MPI_SEND( vsws(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
    219                          comm_inter, ierr )
     229!--       Send the momentum flux (u) at bottom surface to the ocean. First,
     230!--       transfer from 1D surface type to 2D grid.
     231          CALL transfer_1D_to_2D_equal( surf_def_h(0)%usws, surf_lsm_h%usws,   &
     232                                        surf_usm_h%usws )
     233          CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
     234                         15, comm_inter, ierr )
     235!
     236!--       Send the momentum flux (v) at bottom surface to the ocean. First,
     237!--       transfer from 1D surface type to 2D grid.
     238          CALL transfer_1D_to_2D_equal( surf_def_h(0)%vsws, surf_lsm_h%vsws,   &
     239                                        surf_usm_h%vsws )
     240          CALL MPI_SEND( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, &
     241                         16, comm_inter, ierr )
    220242!
    221243!--       Receive u at the bottom surface from the ocean
    222           CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17, &
     244          CALL MPI_RECV( u(0,nysg,nxlg), 1, type_xy, target_id, 17,            &
    223245                         comm_inter, status, ierr )
    224246!
    225247!--       Receive v at the bottom surface from the ocean
    226           CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18, &
     248          CALL MPI_RECV( v(0,nysg,nxlg), 1, type_xy, target_id, 18,            &
    227249                         comm_inter, status, ierr )
    228250!
     
    235257          total_2d_a = 0.0_wp
    236258          total_2d   = 0.0_wp
    237           total_2d(nys:nyn,nxl:nxr) = shf(nys:nyn,nxl:nxr)
    238 
    239           CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
     259!
     260!--       Transfer from 1D surface type to 2D grid.
     261          CALL transfer_1D_to_2D_unequal( surf_def_h(0)%shf, surf_lsm_h%shf,   &
     262                                          surf_usm_h%shf )
     263
     264          CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0,  &
    240265                           comm2d, ierr )
    241266          CALL interpolate_to_ocean( 12 )   
     
    245270             total_2d_a = 0.0_wp
    246271             total_2d   = 0.0_wp
    247              total_2d(nys:nyn,nxl:nxr) = qsws(nys:nyn,nxl:nxr)
     272!
     273!--          Transfer from 1D surface type to 2D grid.
     274             CALL transfer_1D_to_2D_unequal( surf_def_h(0)%qsws,              &
     275                                             surf_lsm_h%qsws,                 &
     276                                             surf_usm_h%qsws )
    248277
    249278             CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, &
     
    254283!--       Receive temperature at the bottom surface from the ocean
    255284          IF ( myid == 0 )  THEN
    256              CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL, &
     285             CALL MPI_RECV( total_2d_a(-nbgp,-nbgp), ngp_a, MPI_REAL,          &
    257286                            target_id, 14, comm_inter, status, ierr )   
    258287          ENDIF
     
    265294          total_2d_a = 0.0_wp
    266295          total_2d   = 0.0_wp
    267           total_2d(nys:nyn,nxl:nxr) = usws(nys:nyn,nxl:nxr)
     296!
     297!--       Transfer from 1D surface type to 2D grid.
     298          CALL transfer_1D_to_2D_unequal( surf_def_h(0)%usws, surf_lsm_h%usws, &
     299                                          surf_usm_h%usws )
    268300          CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
    269301                           comm2d, ierr )
     
    273305          total_2d_a = 0.0_wp
    274306          total_2d   = 0.0_wp
    275           total_2d(nys:nyn,nxl:nxr) = vsws(nys:nyn,nxl:nxr)
     307!
     308!--       Transfer from 1D surface type to 2D grid.
     309          CALL transfer_1D_to_2D_unequal( surf_def_h(0)%usws, surf_lsm_h%usws, &
     310                                          surf_usm_h%usws )
    276311          CALL MPI_REDUCE( total_2d, total_2d_a, ngp_a, MPI_REAL, MPI_SUM, 0, &
    277312                           comm2d, ierr )
     
    308343!
    309344!--       Receive heat flux at the sea surface (top) from the atmosphere
    310           CALL MPI_RECV( tswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
     345          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 12, &
    311346                         comm_inter, status, ierr )
     347          CALL transfer_2D_to_1D_equal( surf_def_h(2)%shf )
    312348!
    313349!--       Receive humidity flux from the atmosphere (bottom)
    314350!--       and add it to the heat flux at the sea surface (top)...
    315351          IF ( humidity_remote )  THEN
    316              CALL MPI_RECV( qswst_remote(nysg,nxlg), ngp_xy, MPI_REAL, &
     352             CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, &
    317353                            target_id, 13, comm_inter, status, ierr )
     354             CALL transfer_2D_to_1D_equal( surf_def_h(2)%qsws )
    318355          ENDIF
    319356!
     
    323360!
    324361!--       Receive momentum flux (u) at the sea surface (top) from the atmosphere
    325           CALL MPI_RECV( uswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
     362          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 15, &
    326363                         comm_inter, status, ierr )
     364          CALL transfer_2D_to_1D_equal( surf_def_h(2)%usws )
    327365!
    328366!--       Receive momentum flux (v) at the sea surface (top) from the atmosphere
    329           CALL MPI_RECV( vswst(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
     367          CALL MPI_RECV( surface_flux(nysg,nxlg), ngp_xy, MPI_REAL, target_id, 16, &
    330368                         comm_inter, status, ierr )
     369          CALL transfer_2D_to_1D_equal( surf_def_h(2)%vsws )
    331370!
    332371!--       Send u to the atmosphere
     
    350389          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
    351390                          ierr )
    352           tswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
     391          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%shf )
    353392!
    354393!--       Receive humidity flux at the sea surface (top) from the atmosphere
     
    361400             CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, &
    362401                             comm2d, ierr)
    363              qswst_remote(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
     402             CALL transfer_2D_to_1D_unequal( surf_def_h(2)%qsws )
    364403          ENDIF
    365404!
     
    381420          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, &
    382421                          0, comm2d, ierr )
    383           uswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
     422          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%usws )
    384423!
    385424!--       Receive momentum flux (v) at the sea surface (top) from the atmosphere
     
    391430          CALL MPI_BCAST( total_2d_o(-nbgp,-nbgp), ngp_o, MPI_REAL, 0, comm2d, &
    392431                          ierr )
    393           vswst(nysg:nyng,nxlg:nxrg) = total_2d_o(nysg:nyng,nxlg:nxrg)
     432          CALL transfer_2D_to_1D_unequal( surf_def_h(2)%vsws )
    394433!
    395434!--       Send u to atmosphere
     
    415454       IF ( humidity_remote )  THEN
    416455!
    417 !--       Here tswst is still the sum of atmospheric bottom heat fluxes,
     456!--       Here top heat flux is still the sum of atmospheric bottom heat fluxes,
    418457!--       * latent heat of vaporization in m2/s2, or 540 cal/g, or 40.65 kJ/mol
    419458!--       /(rho_atm(=1.0)*c_p)
    420           tswst = tswst + qswst_remote * l_v / cp
    421 !
    422 !--        ...and convert it to a salinity flux at the sea surface (top)
    423 !--       following Steinhorn (1991), JPO 21, pp. 1681-1683:
    424 !--       S'w' = -S * evaporation / ( rho_water * ( 1 - S ) )
    425           saswst = -1.0_wp * sa(nzt,:,:) * 0.001_wp * qswst_remote /  &
    426                     ( rho_ocean(nzt,:,:) * ( 1.0_wp - sa(nzt,:,:) * 0.001_wp ) )
     459          DO  m = 1, surf_def_h(2)%ns
     460             i = surf_def_h(2)%i(m)
     461             j = surf_def_h(2)%j(m)
     462             
     463             surf_def_h(2)%shf(m) = surf_def_h(2)%shf(m) +                     &
     464                                    surf_def_h(2)%qsws(m) * l_v / cp
     465!
     466!--          ...and convert it to a salinity flux at the sea surface (top)
     467!--          following Steinhorn (1991), JPO 21, pp. 1681-1683:
     468!--          S'w' = -S * evaporation / ( rho_water * ( 1 - S ) )
     469             surf_def_h(2)%sasws(m) = -1.0_wp * sa(nzt,j,i) * 0.001_wp *       &
     470                                      surf_def_h(2)%qsws(m) /                  &
     471                                    ( rho_ocean(nzt,j,i) *                     &
     472                                      ( 1.0_wp - sa(nzt,j,i) * 0.001_wp )      &
     473                                    )
     474          ENDDO
    427475       ENDIF
    428476
    429477!
    430478!--    Adjust the kinematic heat flux with respect to ocean density
    431 !--    (constants are the specific heat capacities for air and water)
    432 !--    now tswst is the ocean top heat flux
    433        tswst = tswst / rho_ocean(nzt,:,:) * cp / cpw
    434 
    435 !
    436 !--    Adjust the momentum fluxes with respect to ocean density
    437        uswst = uswst / rho_ocean(nzt,:,:)
    438        vswst = vswst / rho_ocean(nzt,:,:)
     479!--    (constants are the specific heat capacities for air and water), as well
     480!--    as momentum fluxes
     481       DO  m = 1, surf_def_h(2)%ns
     482          i = surf_def_h(2)%i(m)
     483          j = surf_def_h(2)%j(m)
     484          surf_def_h(2)%shf(m) = surf_def_h(2)%shf(m) / rho_ocean(nzt,j,i) *   &
     485                                 cp / cpw
     486
     487          surf_def_h(2)%usws(m) = surf_def_h(2)%usws(m) / rho_ocean(nzt,j,i)
     488          surf_def_h(2)%vsws(m) = surf_def_h(2)%vsws(m) / rho_ocean(nzt,j,i)
     489       ENDDO
    439490
    440491    ENDIF
     
    447498
    448499#endif
     500
     501     CONTAINS
     502
     503!       Description:
     504!------------------------------------------------------------------------------!
     505!>      Data transfer from 1D surface-data type to 2D dummy array for equal
     506!>      grids in atmosphere and ocean.
     507!------------------------------------------------------------------------------!
     508        SUBROUTINE transfer_1D_to_2D_equal( def_1d, lsm_1d, usm_1d )
     509
     510           IMPLICIT NONE
     511
     512            INTEGER(iwp) ::  i   !< running index x
     513            INTEGER(iwp) ::  j   !< running index y
     514            INTEGER(iwp) ::  m   !< running index surface type
     515
     516            REAL(wp), DIMENSION(1:surf_def_h(0)%ns) ::  def_1d !< 1D surface flux, default surfaces
     517            REAL(wp), DIMENSION(1:surf_lsm_h%ns)    ::  lsm_1d !< 1D surface flux, natural surfaces
     518            REAL(wp), DIMENSION(1:surf_usm_h%ns)    ::  usm_1d !< 1D surface flux, urban surfaces
     519!
     520!--         Transfer surface flux at default surfaces to 2D grid
     521            DO  m = 1, surf_def_h(0)%ns
     522               i = surf_def_h(0)%i(m)
     523               j = surf_def_h(0)%j(m)
     524               surface_flux(j,i) = def_1d(m)
     525            ENDDO
     526!
     527!--         Transfer surface flux at natural surfaces to 2D grid
     528            IF ( land_surface )  THEN
     529               DO  m = 1, SIZE(lsm_1d)
     530                  i = surf_lsm_h%i(m)
     531                  j = surf_lsm_h%j(m)
     532                  surface_flux(j,i) = lsm_1d(m)
     533               ENDDO
     534            ENDIF
     535!
     536!--         Transfer surface flux at natural surfaces to 2D grid
     537            IF ( urban_surface )  THEN
     538               DO  m = 1, SIZE(usm_1d)
     539                  i = surf_usm_h%i(m)
     540                  j = surf_usm_h%j(m)
     541                  surface_flux(j,i) = usm_1d(m)
     542               ENDDO
     543            ENDIF
     544
     545        END SUBROUTINE transfer_1D_to_2D_equal
     546
     547!       Description:
     548!------------------------------------------------------------------------------!
     549!>      Data transfer from 2D array for equal grids onto 1D surface-data type
     550!>      array.
     551!------------------------------------------------------------------------------!
     552        SUBROUTINE transfer_2D_to_1D_equal( def_1d )
     553
     554           IMPLICIT NONE
     555
     556            INTEGER(iwp) ::  i   !< running index x
     557            INTEGER(iwp) ::  j   !< running index y
     558            INTEGER(iwp) ::  m   !< running index surface type
     559
     560            REAL(wp), DIMENSION(1:surf_def_h(2)%ns) ::  def_1d !< 1D surface flux, default surfaces
     561!
     562!--         Transfer surface flux to 1D surface type, only for default surfaces
     563            DO  m = 1, surf_def_h(2)%ns
     564               i = surf_def_h(2)%i(m)
     565               j = surf_def_h(2)%j(m)
     566               def_1d(m) = surface_flux(j,i)
     567            ENDDO
     568
     569        END SUBROUTINE transfer_2D_to_1D_equal
     570
     571!       Description:
     572!------------------------------------------------------------------------------!
     573!>      Data transfer from 1D surface-data type to 2D dummy array from unequal
     574!>      grids in atmosphere and ocean.
     575!------------------------------------------------------------------------------!
     576        SUBROUTINE transfer_1D_to_2D_unequal( def_1d, lsm_1d, usm_1d )
     577
     578           IMPLICIT NONE
     579
     580            INTEGER(iwp) ::  i   !< running index x
     581            INTEGER(iwp) ::  j   !< running index y
     582            INTEGER(iwp) ::  m   !< running index surface type
     583
     584            REAL(wp), DIMENSION(1:surf_def_h(0)%ns) ::  def_1d !< 1D surface flux, default surfaces
     585            REAL(wp), DIMENSION(1:surf_lsm_h%ns)    ::  lsm_1d !< 1D surface flux, natural surfaces
     586            REAL(wp), DIMENSION(1:surf_usm_h%ns)    ::  usm_1d !< 1D surface flux, urban surfaces
     587!
     588!--         Transfer surface flux at default surfaces to 2D grid. Transfer no
     589!--         ghost-grid points since total_2d is a global array.
     590            DO  m = 1, SIZE(def_1d)
     591               i = surf_def_h(0)%i(m)
     592               j = surf_def_h(0)%j(m)
     593
     594               IF ( i >= nxl  .AND.  i <= nxr  .AND.                           &
     595                    j >= nys  .AND.  j <= nyn )  THEN
     596                  total_2d(j,i) = def_1d(m)
     597               ENDIF
     598            ENDDO
     599!
     600!--         Transfer surface flux at natural surfaces to 2D grid
     601            IF ( land_surface )  THEN
     602               DO  m = 1, SIZE(lsm_1d)
     603                  i = surf_lsm_h%i(m)
     604                  j = surf_lsm_h%j(m)
     605
     606                  IF ( i >= nxl  .AND.  i <= nxr  .AND.                        &
     607                       j >= nys  .AND.  j <= nyn )  THEN
     608                     total_2d(j,i) = lsm_1d(m)
     609                  ENDIF
     610               ENDDO
     611            ENDIF
     612!
     613!--         Transfer surface flux at natural surfaces to 2D grid
     614            IF ( urban_surface )  THEN
     615               DO  m = 1, SIZE(usm_1d)
     616                  i = surf_usm_h%i(m)
     617                  j = surf_usm_h%j(m)
     618
     619                  IF ( i >= nxl  .AND.  i <= nxr  .AND.                        &
     620                       j >= nys  .AND.  j <= nyn )  THEN
     621                     total_2d(j,i) = usm_1d(m)
     622                  ENDIF
     623               ENDDO
     624            ENDIF
     625
     626        END SUBROUTINE transfer_1D_to_2D_unequal
     627
     628!       Description:
     629!------------------------------------------------------------------------------!
     630!>      Data transfer from 2D dummy array from unequal grids to 1D surface-data
     631!>      type.
     632!------------------------------------------------------------------------------!
     633        SUBROUTINE transfer_2D_to_1D_unequal( def_1d )
     634
     635           IMPLICIT NONE
     636
     637            INTEGER(iwp) ::  i   !< running index x
     638            INTEGER(iwp) ::  j   !< running index y
     639            INTEGER(iwp) ::  m   !< running index surface type
     640
     641            REAL(wp), DIMENSION(1:surf_def_h(2)%ns) ::  def_1d !< 1D surface flux, default surfaces
     642!
     643!--         Transfer 2D surface flux to default surfaces data type. Transfer no
     644!--         ghost-grid points since total_2d is a global array.
     645            DO  m = 1, SIZE(def_1d)
     646               i = surf_def_h(2)%i(m)
     647               j = surf_def_h(2)%j(m)
     648
     649               IF ( i >= nxl  .AND.  i <= nxr  .AND.                           &
     650                    j >= nys  .AND.  j <= nyn )  THEN
     651                  def_1d(m) = total_2d_o(j,i)
     652               ENDIF
     653            ENDDO
     654
     655
     656        END SUBROUTINE transfer_2D_to_1D_unequal
    449657
    450658  END SUBROUTINE surface_coupler
Note: See TracChangeset for help on using the changeset viewer.