[532] | 1 | MODULE cpl_oasis3 |
---|
| 2 | !!====================================================================== |
---|
| 3 | !! *** MODULE cpl_oasis *** |
---|
| 4 | !! Coupled O/A : coupled ocean-atmosphere case using OASIS3 V. prism_2_4 |
---|
| 5 | !! special case: NEMO OPA/LIM coupled to ECHAM5 |
---|
| 6 | !!===================================================================== |
---|
| 7 | !! History : |
---|
| 8 | !! 9.0 ! 04-06 (R. Redler, NEC CCRLE, Germany) Original code |
---|
| 9 | !! " " ! 04-11 (R. Redler, N. Keenlyside) revision |
---|
| 10 | !! " " ! 04-11 (V. Gayler, MPI M&D) Grid writing |
---|
| 11 | !! " " ! 05-08 (R. Redler, W. Park) frld initialization, paral(2) revision |
---|
| 12 | !! " " ! 05-09 (R. Redler) extended to allow for communication over root only |
---|
| 13 | !! " " ! 06-01 (W. Park) modification of physical part |
---|
| 14 | !! " " ! 06-02 (R. Redler, W. Park) buffer array fix for root exchange |
---|
| 15 | !!---------------------------------------------------------------------- |
---|
| 16 | #if defined key_oasis3 |
---|
| 17 | !!---------------------------------------------------------------------- |
---|
| 18 | !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3 |
---|
| 19 | !!---------------------------------------------------------------------- |
---|
| 20 | !!---------------------------------------------------------------------- |
---|
| 21 | !! cpl_prism_init : initialization of coupled mode communication |
---|
| 22 | !! cpl_prism_define : definition of grid and fields |
---|
| 23 | !! cpl_prism_send : send out fields in coupled mode |
---|
| 24 | !! cpl_prism_recv : receive fields in coupled mode |
---|
| 25 | !! cpl_prism_finalize : finalize the coupled mode communication |
---|
| 26 | !!---------------------------------------------------------------------- |
---|
| 27 | !! * Modules used |
---|
| 28 | !##################### WARNING coupled mode ############################### |
---|
| 29 | !##################### WARNING coupled mode ############################### |
---|
| 30 | ! Following lines must be enabled if coupling with OASIS |
---|
| 31 | ! |
---|
| 32 | ! USE mod_prism_proto ! OASIS3 prism module |
---|
| 33 | ! USE mod_prism_def_partition_proto! OASIS3 prism module for partitioning |
---|
| 34 | ! USE mod_prism_grids_writing ! OASIS3 prism module for writing grid files |
---|
| 35 | ! USE mod_prism_put_proto ! OASIS3 prism module for sending |
---|
| 36 | ! USE mod_prism_get_proto ! OASIS3 prism module for receiving |
---|
| 37 | ! USE mod_prism_grids_writing ! OASIS3 prism module for writing grids |
---|
| 38 | !##################### WARNING coupled mode ############################### |
---|
| 39 | !##################### WARNING coupled mode ############################### |
---|
| 40 | #if defined key_mpp_mpi |
---|
[629] | 41 | USE lib_mpp, only : mppsize, mpprank ! message passing |
---|
| 42 | USE lib_mpp, only : mppsend ! message passing |
---|
| 43 | USE lib_mpp, only : mpprecv ! message passing |
---|
[532] | 44 | #endif |
---|
| 45 | USE daymod ! date and time info |
---|
| 46 | USE dom_oce ! ocean space and time domain |
---|
[708] | 47 | USE sbc_ice ! surface boundary condition: ice |
---|
[532] | 48 | USE in_out_manager ! I/O manager |
---|
| 49 | USE par_oce ! |
---|
| 50 | USE phycst, only : rt0 ! freezing point of sea water |
---|
| 51 | |
---|
| 52 | USE oce, only: tn, un, vn |
---|
[881] | 53 | USE ice_2, only: frld, hicif, hsnif |
---|
[532] | 54 | |
---|
| 55 | IMPLICIT NONE |
---|
| 56 | ! |
---|
| 57 | ! Exchange parameters for coupling ORCA-LIM with ECHAM5 |
---|
| 58 | ! |
---|
| 59 | #if defined key_cpl_ocevel |
---|
| 60 | INTEGER, PARAMETER :: nsend = 6 |
---|
| 61 | #else |
---|
| 62 | INTEGER, PARAMETER :: nsend = 4 |
---|
| 63 | #endif |
---|
| 64 | |
---|
| 65 | #if defined key_cpl_discharge |
---|
| 66 | INTEGER, PARAMETER :: nrecv = 20 |
---|
| 67 | #else |
---|
| 68 | INTEGER, PARAMETER :: nrecv = 17 |
---|
| 69 | #endif |
---|
| 70 | |
---|
| 71 | INTEGER, DIMENSION(nsend) :: send_id |
---|
| 72 | INTEGER, DIMENSION(nrecv) :: recv_id |
---|
| 73 | |
---|
| 74 | CHARACTER(len=32) :: cpl_send (nsend) |
---|
| 75 | CHARACTER(len=32) :: cpl_recv (nrecv) |
---|
| 76 | |
---|
| 77 | PRIVATE |
---|
| 78 | |
---|
| 79 | INTEGER :: localRank ! local MPI rank |
---|
| 80 | INTEGER :: comp_id ! id returned by prism_init_comp |
---|
| 81 | |
---|
| 82 | INTEGER :: range(5) |
---|
| 83 | |
---|
| 84 | INTEGER, PARAMETER :: localRoot = 0 |
---|
| 85 | INTEGER :: localSize ! local MPI size |
---|
| 86 | INTEGER :: localComm ! local MPI size |
---|
| 87 | LOGICAL :: commRank ! true for ranks doing OASIS communication |
---|
| 88 | |
---|
| 89 | LOGICAL, SAVE :: prism_was_initialized |
---|
| 90 | LOGICAL, SAVE :: prism_was_terminated |
---|
| 91 | INTEGER, SAVE :: write_grid |
---|
| 92 | |
---|
| 93 | INTEGER :: ierror ! return error code |
---|
| 94 | |
---|
| 95 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving |
---|
| 96 | |
---|
| 97 | #ifdef key_cpl_rootexchg |
---|
| 98 | LOGICAL :: rootexchg =.true. ! logical switch |
---|
| 99 | #else |
---|
| 100 | LOGICAL :: rootexchg =.false. ! logical switch |
---|
| 101 | #endif |
---|
| 102 | |
---|
| 103 | REAL(wp), DIMENSION(:), ALLOCATABLE :: buffer ! Temporary buffer for exchange |
---|
| 104 | INTEGER, DIMENSION(:,:), ALLOCATABLE :: ranges ! Temporary buffer for exchange |
---|
| 105 | |
---|
| 106 | !! Routine accessibility |
---|
| 107 | PUBLIC cpl_prism_init |
---|
| 108 | PUBLIC cpl_prism_define |
---|
| 109 | PUBLIC cpl_prism_send |
---|
| 110 | PUBLIC cpl_prism_recv |
---|
| 111 | PUBLIC cpl_prism_finalize |
---|
| 112 | |
---|
| 113 | PUBLIC send_id, recv_id |
---|
| 114 | |
---|
| 115 | !!---------------------------------------------------------------------- |
---|
| 116 | !! OPA 9.0 , LOCEAN-IPSL (2006) |
---|
[699] | 117 | !! $Id$ |
---|
[532] | 118 | !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) |
---|
| 119 | !!---------------------------------------------------------------------- |
---|
| 120 | |
---|
| 121 | CONTAINS |
---|
| 122 | |
---|
| 123 | SUBROUTINE cpl_prism_init( localCommunicator ) |
---|
| 124 | |
---|
| 125 | IMPLICIT NONE |
---|
| 126 | |
---|
| 127 | !!------------------------------------------------------------------- |
---|
| 128 | !! *** ROUTINE cpl_prism_init *** |
---|
| 129 | !! |
---|
| 130 | !! ** Purpose : Initialize coupled mode communication for ocean |
---|
| 131 | !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) |
---|
| 132 | !! |
---|
| 133 | !! ** Method : OASIS3 MPI communication |
---|
| 134 | !!-------------------------------------------------------------------- |
---|
| 135 | !! * Arguments |
---|
| 136 | !! |
---|
| 137 | INTEGER, INTENT(OUT) :: localCommunicator |
---|
| 138 | !! |
---|
| 139 | !! * Local declarations |
---|
| 140 | !! |
---|
| 141 | CHARACTER(len=4) :: comp_name ! name of this PRISM component |
---|
| 142 | !! |
---|
| 143 | !!-------------------------------------------------------------------- |
---|
| 144 | !! |
---|
| 145 | IF(lwp) WRITE(numout,*) |
---|
| 146 | IF(lwp) WRITE(numout,*) 'cpl_prism_init : initialization in coupled ocean/atmosphere case' |
---|
| 147 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' |
---|
| 148 | IF(lwp) WRITE(numout,*) |
---|
| 149 | |
---|
| 150 | #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily |
---|
| 151 | IF(lwp)WRITE(numout,cform_err) |
---|
| 152 | IF(lwp)WRITE(numout,*) ' key_coupled and key_flx_bulk_* key_flx_forced_daily are incompatible' |
---|
| 153 | nstop = nstop + 1 |
---|
| 154 | #endif |
---|
| 155 | |
---|
| 156 | comp_name = 'opa9' |
---|
| 157 | |
---|
| 158 | !------------------------------------------------------------------ |
---|
| 159 | ! 1st Initialize the PRISM system for the application |
---|
| 160 | !------------------------------------------------------------------ |
---|
| 161 | |
---|
| 162 | CALL prism_init_comp_proto ( comp_id, comp_name, ierror ) |
---|
| 163 | IF ( ierror /= PRISM_Ok ) & |
---|
| 164 | CALL prism_abort_proto (comp_id, 'cpl_prism_init', 'Failure in prism_init_comp_proto') |
---|
| 165 | prism_was_initialized = .true. |
---|
| 166 | |
---|
| 167 | !------------------------------------------------------------------ |
---|
| 168 | ! 3rd Get an MPI communicator for OPA local communication |
---|
| 169 | !------------------------------------------------------------------ |
---|
| 170 | |
---|
| 171 | CALL prism_get_localcomm_proto ( localComm, ierror ) |
---|
| 172 | IF ( ierror /= PRISM_Ok ) & |
---|
| 173 | CALL prism_abort_proto (comp_id, 'cpl_prism_init','Failure in prism_get_localcomm_proto' ) |
---|
| 174 | |
---|
| 175 | localCommunicator = localComm |
---|
| 176 | |
---|
| 177 | END SUBROUTINE cpl_prism_init |
---|
| 178 | |
---|
| 179 | |
---|
| 180 | SUBROUTINE cpl_prism_define () |
---|
| 181 | |
---|
| 182 | IMPLICIT NONE |
---|
| 183 | |
---|
| 184 | !!------------------------------------------------------------------- |
---|
| 185 | !! *** ROUTINE cpl_prism_define *** |
---|
| 186 | !! |
---|
| 187 | !! ** Purpose : Define grid and field information for ocean |
---|
| 188 | !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) |
---|
| 189 | !! |
---|
| 190 | !! ** Method : OASIS3 MPI communication |
---|
| 191 | !!-------------------------------------------------------------------- |
---|
| 192 | !! * Arguments |
---|
| 193 | !! |
---|
| 194 | !! * Local declarations |
---|
| 195 | !! |
---|
| 196 | INTEGER :: grid_id(2) ! id returned by prism_def_grid |
---|
| 197 | INTEGER :: part_id |
---|
| 198 | |
---|
| 199 | INTEGER :: paral(5) ! OASIS3 box partition |
---|
| 200 | |
---|
| 201 | INTEGER :: shape(2,3) ! shape of arrays passed to PSMILe |
---|
| 202 | INTEGER :: nodim(2) |
---|
| 203 | INTEGER :: data_type ! data type of transients |
---|
| 204 | |
---|
| 205 | INTEGER :: ji, jj ! local loop indicees |
---|
| 206 | INTEGER :: nx, ny, nc ! local variables |
---|
| 207 | INTEGER :: im1, ip1 |
---|
| 208 | INTEGER :: jm1, jp1 |
---|
| 209 | INTEGER :: i_grid ! loop index |
---|
| 210 | INTEGER :: info |
---|
| 211 | INTEGER :: maxlen |
---|
| 212 | INTEGER :: mask(jpi,jpj) |
---|
| 213 | REAL(kind=wp) :: area(jpi,jpj) |
---|
| 214 | |
---|
| 215 | CHARACTER(len=4) :: point_name ! name of the grid points |
---|
| 216 | |
---|
| 217 | REAL(kind=wp) :: rclam(jpi,jpj,4) |
---|
| 218 | REAL(kind=wp) :: rcphi(jpi,jpj,4) |
---|
| 219 | |
---|
| 220 | REAL(kind=wp) :: glam_b(jpi,jpj) ! buffer for orca2 grid correction |
---|
| 221 | REAL(kind=wp) :: gphi_b(jpi,jpj) ! buffer for orca2 grid correction |
---|
| 222 | !! |
---|
| 223 | !!-------------------------------------------------------------------- |
---|
| 224 | |
---|
| 225 | IF(lwp) WRITE(numout,*) |
---|
| 226 | IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case' |
---|
| 227 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' |
---|
| 228 | IF(lwp) WRITE(numout,*) |
---|
| 229 | |
---|
| 230 | #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily |
---|
| 231 | IF(lwp)WRITE(numout,cform_err) |
---|
| 232 | IF(lwp)WRITE(numout,*) ' key_coupled and key_flx_bulk_... are incompatible' |
---|
| 233 | nstop = nstop + 1 |
---|
| 234 | #endif |
---|
| 235 | |
---|
| 236 | ! ----------------------------------------------------------------- |
---|
| 237 | ! ... Some initialisation |
---|
| 238 | ! ----------------------------------------------------------------- |
---|
| 239 | |
---|
| 240 | send_id = 0 |
---|
| 241 | recv_id = 0 |
---|
| 242 | |
---|
| 243 | #if defined key_mpp_mpi |
---|
| 244 | |
---|
| 245 | ! ----------------------------------------------------------------- |
---|
| 246 | ! ... Some MPI stuff relevant for optional exchange via root only |
---|
| 247 | ! ----------------------------------------------------------------- |
---|
| 248 | |
---|
| 249 | commRank = .false. |
---|
| 250 | |
---|
[629] | 251 | localRank = mpprank ! from lib_mpp |
---|
| 252 | localSize = mppsize ! from lib_mpp |
---|
[532] | 253 | |
---|
| 254 | IF ( rootexchg ) THEN |
---|
| 255 | IF ( localRank == localRoot ) commRank = .true. |
---|
| 256 | ELSE |
---|
| 257 | commRank = .true. |
---|
| 258 | ENDIF |
---|
| 259 | |
---|
| 260 | IF ( rootexchg .and. localRank == localRoot ) THEN |
---|
| 261 | ALLOCATE(ranges(5,0:localSize-1), stat = ierror) |
---|
| 262 | IF (ierror > 0) THEN |
---|
| 263 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating Integer') |
---|
| 264 | RETURN |
---|
| 265 | ENDIF |
---|
| 266 | ENDIF |
---|
| 267 | |
---|
| 268 | #else |
---|
| 269 | ! |
---|
| 270 | ! For non-parallel configurations the one and only process ("localRoot") |
---|
| 271 | ! takes part in the communication |
---|
| 272 | ! |
---|
| 273 | localRank = localRoot |
---|
| 274 | commRank = .true. |
---|
| 275 | |
---|
| 276 | #endif |
---|
| 277 | |
---|
| 278 | ! ----------------------------------------------------------------- |
---|
| 279 | ! ... If necessary the root process writes the global grid info |
---|
| 280 | ! ----------------------------------------------------------------- |
---|
| 281 | |
---|
| 282 | IF ( localRank == localRoot ) THEN |
---|
| 283 | |
---|
| 284 | WRITE(numout,*)'Opening file SSTOCEAN, unit= 199' |
---|
| 285 | |
---|
| 286 | OPEN (199,STATUS='NEW',FILE="sstocean",FORM='UNFORMATTED',err=310) |
---|
| 287 | |
---|
| 288 | ! In case the sstocean of OASIS3 from a previous run exists |
---|
| 289 | ! the programs jumps to the end of the if-block |
---|
| 290 | ! |
---|
| 291 | !* 2.0 Write exchange fields to OASIS data file. |
---|
| 292 | ! ----------------------------------------- |
---|
| 293 | |
---|
| 294 | WHERE (tmask(:,:,1) > 0.5 ) |
---|
| 295 | mask(:,:) = 0 |
---|
| 296 | ELSE WHERE |
---|
| 297 | mask(:,:) = 1 |
---|
| 298 | END WHERE |
---|
| 299 | |
---|
| 300 | ! Initialise ice mask at the very first start only |
---|
| 301 | frld = 1. |
---|
| 302 | |
---|
| 303 | WRITE(199) 'SSTOCEAN' |
---|
| 304 | WRITE(199) (tn(:,:,1)*mask(:,:))+rt0 |
---|
| 305 | |
---|
| 306 | WRITE(199) 'SICOCEAN' |
---|
| 307 | WRITE(199) (1.-frld(:,:))*mask(:,:) |
---|
| 308 | |
---|
| 309 | #if defined key_cpl_albedo |
---|
| 310 | tn_ice = 271.285 |
---|
| 311 | alb_ice = 0.75 |
---|
| 312 | |
---|
| 313 | WRITE(199) 'STIOCEAN' |
---|
| 314 | WRITE(199) tn_ice(:,:) |
---|
| 315 | |
---|
| 316 | WRITE(199) 'SAIOCEAN' |
---|
| 317 | WRITE(199) alb_ice(:,:) |
---|
| 318 | #else |
---|
| 319 | hicit = 0. |
---|
| 320 | hsnit = 0. |
---|
| 321 | WRITE(199) 'SITOCEAN' |
---|
| 322 | WRITE(199) hicif(:,:)*mask(:,:) |
---|
| 323 | |
---|
| 324 | WRITE(199) 'SNTOCEAN' |
---|
| 325 | WRITE(199) hsnif(:,:)*mask(:,:) |
---|
| 326 | #endif |
---|
| 327 | |
---|
| 328 | #if defined key_cpl_ocevel |
---|
| 329 | un(:,:,1) = 0. |
---|
| 330 | vn(:,:,1) = 0. |
---|
| 331 | |
---|
| 332 | WHERE (umask(:,:,1) > 0.5 ) |
---|
| 333 | mask(:,:) = 0 |
---|
| 334 | ELSE WHERE |
---|
| 335 | mask(:,:) = 1 |
---|
| 336 | END WHERE |
---|
| 337 | |
---|
| 338 | WRITE(199) 'SUNOCEAN' |
---|
| 339 | WRITE(199) un(:,:,1)*mask(:,:) |
---|
| 340 | |
---|
| 341 | WHERE (vmask(:,:,1) > 0.5 ) |
---|
| 342 | mask(:,:) = 0 |
---|
| 343 | ELSE WHERE |
---|
| 344 | mask(:,:) = 1 |
---|
| 345 | END WHERE |
---|
| 346 | |
---|
| 347 | WRITE(199) 'SVNOCEAN' |
---|
| 348 | WRITE(199) vn(:,:,1)*mask(:,:) |
---|
| 349 | #endif |
---|
| 350 | |
---|
| 351 | WRITE(numout,*) |
---|
| 352 | WRITE(numout,*)' sstocean written' |
---|
| 353 | WRITE(numout,*)' ***************' |
---|
| 354 | |
---|
| 355 | CLOSE(199) |
---|
| 356 | |
---|
| 357 | 310 CONTINUE |
---|
| 358 | |
---|
| 359 | CALL prism_start_grids_writing ( write_grid ) |
---|
| 360 | |
---|
| 361 | ENDIF ! localRank == localRoot |
---|
| 362 | |
---|
| 363 | IF ( localRank == localRoot .and. write_grid == 1 ) THEN |
---|
| 364 | |
---|
| 365 | !------------------------------------------------------------------ |
---|
| 366 | ! 1st write global grid information (ORCA tripolar) characteristics |
---|
| 367 | ! for surface coupling into a OASIS3 specific grid file. For |
---|
| 368 | ! surface coupling it is sufficient to specify only one vertical |
---|
| 369 | ! z-level. |
---|
| 370 | !------------------------------------------------------------------ |
---|
| 371 | ! |
---|
| 372 | ! ... Treat corners in the horizontal plane |
---|
| 373 | ! |
---|
| 374 | nx = jpi |
---|
| 375 | ny = jpj |
---|
| 376 | nc = 4 |
---|
| 377 | |
---|
| 378 | DO i_grid = 1, 3 |
---|
| 379 | |
---|
| 380 | IF ( i_grid == 1 ) THEN |
---|
| 381 | |
---|
| 382 | ! -------------------------------------------------------- |
---|
| 383 | ! ... Write the grid info for T points |
---|
| 384 | ! -------------------------------------------------------- |
---|
| 385 | |
---|
| 386 | point_name = 'opat' |
---|
| 387 | |
---|
| 388 | glam_b = glamt |
---|
| 389 | gphi_b = gphit |
---|
| 390 | |
---|
| 391 | DO ji = 1, jpi |
---|
| 392 | DO jj = 1, jpj |
---|
| 393 | |
---|
| 394 | im1 = ji-1 |
---|
| 395 | jm1 = jj-1 |
---|
| 396 | IF (ji == 1) im1 = jpi-2 |
---|
| 397 | IF (jj == 1) jm1 = jj |
---|
| 398 | |
---|
| 399 | rclam(ji,jj,1) = glamf(ji,jj) |
---|
| 400 | rclam(ji,jj,2) = glamf(im1,jj) |
---|
| 401 | rclam(ji,jj,3) = glamf(im1,jm1) |
---|
| 402 | rclam(ji,jj,4) = glamf(ji,jm1) |
---|
| 403 | |
---|
| 404 | rcphi(ji,jj,1) = gphif(ji,jj) |
---|
| 405 | rcphi(ji,jj,2) = gphif(im1,jj) |
---|
| 406 | rcphi(ji,jj,3) = gphif(im1,jm1) |
---|
| 407 | rcphi(ji,jj,4) = gphif(ji,jm1) |
---|
| 408 | |
---|
| 409 | END DO |
---|
| 410 | END DO |
---|
| 411 | |
---|
| 412 | ! Correction of one (land) grid cell of the orca2 grid. |
---|
| 413 | ! It was causing problems with the SCRIP interpolation. |
---|
| 414 | |
---|
| 415 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
| 416 | rclam(145,106,2) = -1.0 |
---|
| 417 | rcphi(145,106,2) = 41.0 |
---|
| 418 | ENDIF |
---|
| 419 | |
---|
| 420 | WHERE (tmask(:,:,1) > 0.5 ) |
---|
| 421 | mask(:,:) = 0 |
---|
| 422 | ELSE WHERE |
---|
| 423 | mask(:,:) = 1 |
---|
| 424 | END WHERE |
---|
| 425 | |
---|
| 426 | area = e1t * e2t |
---|
| 427 | |
---|
| 428 | ELSE IF ( i_grid == 2 ) THEN |
---|
| 429 | |
---|
| 430 | ! -------------------------------------------------------- |
---|
| 431 | ! ... Write the grid info for u points |
---|
| 432 | ! -------------------------------------------------------- |
---|
| 433 | |
---|
| 434 | point_name = 'opau' |
---|
| 435 | |
---|
| 436 | glam_b = glamu |
---|
| 437 | gphi_b = gphiu |
---|
| 438 | |
---|
| 439 | DO ji = 1, jpi |
---|
| 440 | DO jj = 1, jpj |
---|
| 441 | |
---|
| 442 | ip1 = ji+1 |
---|
| 443 | jm1 = jj-1 |
---|
| 444 | |
---|
| 445 | IF (ji == jpiglo) ip1 = 3 |
---|
| 446 | IF (jj == 1) jm1 = jj |
---|
| 447 | |
---|
| 448 | rclam(ji,jj,1) = glamv(ip1,jj) |
---|
| 449 | rclam(ji,jj,2) = glamv(ji,jj) |
---|
| 450 | rclam(ji,jj,3) = glamv(ji,jm1) |
---|
| 451 | rclam(ji,jj,4) = glamv(ip1,jm1) |
---|
| 452 | |
---|
| 453 | rcphi(ji,jj,1) = gphiv(ip1,jj) |
---|
| 454 | rcphi(ji,jj,2) = gphiv(ji,jj) |
---|
| 455 | rcphi(ji,jj,3) = gphiv(ji,jm1) |
---|
| 456 | rcphi(ji,jj,4) = gphiv(ip1,jm1) |
---|
| 457 | |
---|
| 458 | END DO |
---|
| 459 | END DO |
---|
| 460 | |
---|
| 461 | ! Correction of three (land) grid cell of the orca2 grid. |
---|
| 462 | ! It was causing problems with the SCRIP interpolation. |
---|
| 463 | |
---|
| 464 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
| 465 | glam_b(144,106) = -1.0 |
---|
| 466 | gphi_b(144,106) = 40.5 |
---|
| 467 | rclam (144,106,2) = -1.5 |
---|
| 468 | rcphi (144,106,2) = 41.0 |
---|
| 469 | |
---|
| 470 | glam_b(144,107) = -1.0 |
---|
| 471 | gphi_b(144,107) = 41.5 |
---|
| 472 | rclam (144,107,2) = -1.5 |
---|
| 473 | rcphi (144,107,2) = 42.0 |
---|
| 474 | rclam (144,107,3) = -1.5 |
---|
| 475 | rcphi (144,107,3) = 41.0 |
---|
| 476 | |
---|
| 477 | glam_b(144,108) = -1.0 |
---|
| 478 | gphi_b(144,108) = 42.5 |
---|
| 479 | rclam (144,108,2) = -1.5 |
---|
| 480 | rcphi (144,108,2) = 43.0 |
---|
| 481 | rclam (144,108,3) = -1.5 |
---|
| 482 | rcphi (144,108,3) = 42.0 |
---|
| 483 | ENDIF |
---|
| 484 | |
---|
| 485 | WHERE (umask(:,:,1) > 0.5 ) |
---|
| 486 | mask(:,:) = 0 |
---|
| 487 | ELSE WHERE |
---|
| 488 | mask(:,:) = 1 |
---|
| 489 | END WHERE |
---|
| 490 | |
---|
| 491 | area = e1u * e2u |
---|
| 492 | |
---|
| 493 | ELSE IF ( i_grid == 3 ) THEN |
---|
| 494 | |
---|
| 495 | ! -------------------------------------------------------- |
---|
| 496 | ! ... Write the grid info for v points |
---|
| 497 | ! -------------------------------------------------------- |
---|
| 498 | |
---|
| 499 | point_name = 'opav' |
---|
| 500 | |
---|
| 501 | glam_b = glamv |
---|
| 502 | gphi_b = gphiv |
---|
| 503 | |
---|
| 504 | DO ji = 1, jpi |
---|
| 505 | DO jj = 1, jpj |
---|
| 506 | |
---|
| 507 | im1 = ji-1 |
---|
| 508 | jp1 = jj+1 |
---|
| 509 | IF (ji == 1) im1 = jpiglo-2 |
---|
| 510 | IF (jj == jpjglo) jp1 = jj |
---|
| 511 | |
---|
| 512 | rclam(ji,jj,1) = glamu(ji,jp1) |
---|
| 513 | rclam(ji,jj,2) = glamu(im1,jp1) |
---|
| 514 | rclam(ji,jj,3) = glamu(im1,jj) |
---|
| 515 | rclam(ji,jj,4) = glamu(ji,jj) |
---|
| 516 | |
---|
| 517 | rcphi(ji,jj,1) = gphiu(ji,jp1) |
---|
| 518 | rcphi(ji,jj,2) = gphiu(im1,jp1) |
---|
| 519 | rcphi(ji,jj,3) = gphiu(im1,jj) |
---|
| 520 | rcphi(ji,jj,4) = gphiu(ji,jj) |
---|
| 521 | |
---|
| 522 | END DO |
---|
| 523 | END DO |
---|
| 524 | |
---|
| 525 | ! Correction of one (land) grid cell of the orca2 grid. |
---|
| 526 | ! It was causing problems with the SCRIP interpolation. |
---|
| 527 | |
---|
| 528 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
| 529 | rclam(145,105,2) = -1.0 |
---|
| 530 | rcphi(145,105,2) = 40.5 |
---|
| 531 | ENDIF |
---|
| 532 | |
---|
| 533 | WHERE (vmask(:,:,1) > 0.5 ) |
---|
| 534 | mask(:,:) = 0 |
---|
| 535 | ELSE WHERE |
---|
| 536 | mask(:,:) = 1 |
---|
| 537 | END WHERE |
---|
| 538 | |
---|
| 539 | area = e1v * e2v |
---|
| 540 | |
---|
| 541 | ENDIF ! i_grid |
---|
| 542 | |
---|
| 543 | WHERE (glam_b(:,:) < 0.) |
---|
| 544 | glam_b(:,:) = glam_b(:,:) + 360. |
---|
| 545 | END WHERE |
---|
| 546 | WHERE (glam_b(:,:) > 360.) |
---|
| 547 | glam_b(:,:) = glam_b(:,:) - 360. |
---|
| 548 | END WHERE |
---|
| 549 | |
---|
| 550 | WHERE (rclam(:,:,:) < 0.) |
---|
| 551 | rclam(:,:,:) = rclam(:,:,:) + 360. |
---|
| 552 | END WHERE |
---|
| 553 | WHERE (rclam(:,:,:) > 360.) |
---|
| 554 | rclam(:,:,:) = rclam(:,:,:) - 360. |
---|
| 555 | END WHERE |
---|
| 556 | |
---|
| 557 | mask(:,jpjglo)=1 |
---|
| 558 | |
---|
| 559 | CALL prism_write_grid ( point_name, nx, ny, glam_b, gphi_b ) |
---|
| 560 | CALL prism_write_corner ( point_name, nx, ny, nc, rclam, rcphi ) |
---|
| 561 | CALL prism_write_mask ( point_name, nx, ny, mask ) |
---|
| 562 | CALL prism_write_area ( point_name, nx, ny, area ) |
---|
| 563 | |
---|
| 564 | END DO ! i_grid |
---|
| 565 | |
---|
| 566 | CALL prism_terminate_grids_writing () |
---|
| 567 | |
---|
| 568 | ENDIF ! localRank == localRoot .and. write_grid == 1 |
---|
| 569 | |
---|
| 570 | ! ----------------------------------------------------------------- |
---|
| 571 | ! ... Define the partition |
---|
| 572 | ! ----------------------------------------------------------------- |
---|
| 573 | |
---|
| 574 | IF ( rootexchg ) THEN |
---|
| 575 | |
---|
| 576 | paral(1) = 2 ! box partitioning |
---|
| 577 | paral(2) = 0 ! NEMO lower left corner global offset |
---|
| 578 | paral(3) = jpiglo ! local extent in i |
---|
| 579 | paral(4) = jpjglo ! local extent in j |
---|
| 580 | paral(5) = jpiglo ! global extent in x |
---|
| 581 | |
---|
| 582 | range(1) = nimpp-1+nldi ! global start in i |
---|
| 583 | range(2) = nlei-nldi+1 ! local size in i of valid region |
---|
| 584 | range(3) = njmpp-1+nldj ! global start in j |
---|
| 585 | range(4) = nlej-nldj+1 ! local size in j of valid region |
---|
| 586 | range(5) = range(2) & |
---|
| 587 | * range(4) ! local horizontal size |
---|
| 588 | |
---|
| 589 | IF(ln_ctl) THEN |
---|
| 590 | write(numout,*) ' rootexchg: range(1:5)', range |
---|
| 591 | ENDIF |
---|
| 592 | |
---|
| 593 | ! |
---|
| 594 | ! Collect ranges from all NEMO procs on the local root process |
---|
| 595 | ! |
---|
| 596 | CALL mpi_gather(range, 5, MPI_INTEGER, & |
---|
| 597 | ranges, 5, MPI_INTEGER, localRoot, localComm, ierror) |
---|
| 598 | |
---|
| 599 | IF ( localRank == localRoot ) THEN |
---|
| 600 | |
---|
| 601 | maxlen = maxval(ranges(5,:)) |
---|
| 602 | |
---|
| 603 | ALLOCATE(buffer(1:maxlen), stat = ierror) |
---|
| 604 | IF (ierror > 0) THEN |
---|
| 605 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating buffer') |
---|
| 606 | RETURN |
---|
| 607 | ENDIF |
---|
| 608 | |
---|
| 609 | ENDIF |
---|
| 610 | |
---|
| 611 | ELSE |
---|
| 612 | |
---|
| 613 | paral(1) = 2 ! box partitioning |
---|
| 614 | !2dtest paral(2) = jpiglo & |
---|
| 615 | !2dtest * (nldj-1+njmpp-1) & |
---|
| 616 | !2dtest + (nldi-1+nimpp-1) ! NEMO lower left corner global offset |
---|
| 617 | paral(2) = jpiglo & |
---|
| 618 | * (nldj-1+njmpp-1) ! NEMO lower left corner global offset |
---|
| 619 | paral(3) = nlei-nldi+1 ! local extent in i |
---|
| 620 | paral(4) = nlej-nldj+1 ! local extent in j |
---|
| 621 | paral(5) = jpiglo ! global extent in x |
---|
| 622 | |
---|
| 623 | IF(ln_ctl) THEN |
---|
| 624 | print*, ' multiexchg: paral (1:5)', paral |
---|
| 625 | print*, ' multiexchg: jpi, jpj =', jpi, jpj |
---|
| 626 | print*, ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp |
---|
| 627 | print*, ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp |
---|
| 628 | ENDIF |
---|
| 629 | |
---|
| 630 | IF ( paral(3) /= nlei-nldi+1 ) THEN |
---|
| 631 | print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define' |
---|
| 632 | print*, 'cpl_prism_define: local extend in i is ', paral(3), ' should equal ', nlei-nldi+1 |
---|
| 633 | ENDIF |
---|
| 634 | IF ( paral(4) /= nlej-nldj+1 ) THEN |
---|
| 635 | print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define' |
---|
| 636 | print*, 'cpl_prism_define: local extend in j is ', paral(4), ' should equal ', nlej-nldj+1 |
---|
| 637 | ENDIF |
---|
| 638 | |
---|
| 639 | ENDIF |
---|
| 640 | |
---|
| 641 | IF ( commRank ) & |
---|
| 642 | CALL prism_def_partition_proto ( part_id, paral, ierror ) |
---|
| 643 | |
---|
| 644 | grid_id(1)= part_id |
---|
| 645 | |
---|
| 646 | !------------------------------------------------------------------ |
---|
| 647 | ! 3rd Declare the transient variables |
---|
| 648 | !------------------------------------------------------------------ |
---|
| 649 | ! |
---|
| 650 | ! ... Define symbolic names for the transient fields send by the ocean |
---|
| 651 | ! These must be identical to the names specified in the SMIOC file. |
---|
| 652 | ! |
---|
| 653 | cpl_send( 1)='SSTOCEAN' ! sea surface temperature -> sst_io |
---|
| 654 | cpl_send( 2)='SICOCEAN' ! sea ice area fraction -> 1.-frld |
---|
| 655 | #if defined key_cpl_albedo |
---|
| 656 | cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice -> tn_ice |
---|
| 657 | cpl_send( 4)='SAIOCEAN' ! albedo over sea ice -> alb_ice |
---|
| 658 | #else |
---|
| 659 | cpl_send( 3)='SITOCEAN' ! sea ice thickness -> hicif (only 1 layer available!) |
---|
| 660 | cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice -> hsnif |
---|
| 661 | #endif |
---|
| 662 | #if defined key_cpl_ocevel |
---|
| 663 | cpl_send( 5)='SUNOCEAN' ! U-velocity -> un |
---|
| 664 | cpl_send( 6)='SVNOCEAN' ! V-velocity -> vn |
---|
| 665 | #endif |
---|
| 666 | ! |
---|
| 667 | ! ... Define symbolic names for transient fields received by the ocean. |
---|
| 668 | ! These must be identical to the names specified in the SMIOC file. |
---|
| 669 | ! |
---|
| 670 | ! ... a) U-Grid fields |
---|
| 671 | ! |
---|
| 672 | cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress |
---|
| 673 | cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress |
---|
| 674 | cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice |
---|
| 675 | cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice |
---|
| 676 | ! |
---|
| 677 | ! ... a) V-Grid fields |
---|
| 678 | ! |
---|
| 679 | cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress |
---|
| 680 | cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress |
---|
| 681 | cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice |
---|
| 682 | cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice |
---|
| 683 | ! |
---|
| 684 | ! ... a) T-Grid fields |
---|
| 685 | ! |
---|
| 686 | cpl_recv( 9)='FRWOCEPE' ! P-E over water -> zpew |
---|
| 687 | cpl_recv(10)='FRIOCEPE' ! P-E over ice -> zpei |
---|
| 688 | cpl_recv(11)='FRROCESN' ! surface downward snow fall -> zpsol |
---|
| 689 | cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice -> zevice |
---|
| 690 | |
---|
| 691 | cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux -> qsr_oce |
---|
| 692 | cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air -> qnsr_oce |
---|
| 693 | cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice -> qsr_ice |
---|
| 694 | cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice -> qnsr_ice |
---|
| 695 | cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative -> dqns_ice |
---|
| 696 | |
---|
| 697 | #ifdef key_cpl_discharge |
---|
| 698 | cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean -> calving |
---|
| 699 | cpl_recv(19)='FRWOCERD' ! river discharge into ocean -> zrunriv |
---|
| 700 | cpl_recv(20)='FRWOCECD' ! continental discharge into ocean -> zruncot |
---|
| 701 | #endif |
---|
| 702 | ! |
---|
| 703 | ! data_type has to be PRISM_REAL as PRISM_DOUBLE is not supported. |
---|
| 704 | ! For exchange of double precision fields the OASIS3 has to be compiled |
---|
| 705 | ! with use_realtype_single. (see OASIS3 User Guide prism_2-4, 5th Ed., |
---|
| 706 | ! p. 13 and p. 53 for further explanation.) |
---|
| 707 | ! |
---|
| 708 | data_type = PRISM_REAL |
---|
| 709 | |
---|
| 710 | nodim(1) = 3 ! check |
---|
| 711 | nodim(2) = 0 |
---|
| 712 | |
---|
| 713 | ! |
---|
| 714 | ! ... Define the shape for the area that excludes the halo |
---|
| 715 | ! For serial configuration (key_mpp_mpi not being active) |
---|
| 716 | ! nl* is set to the global values 1 and jp*glo. |
---|
| 717 | ! |
---|
| 718 | IF ( rootexchg ) THEN |
---|
| 719 | shape(1,1) = 1 |
---|
| 720 | shape(2,1) = jpiglo |
---|
| 721 | shape(1,2) = 1 |
---|
| 722 | shape(2,2) = jpjglo |
---|
| 723 | shape(1,3) = 1 |
---|
| 724 | shape(2,3) = 1 |
---|
| 725 | ELSE |
---|
| 726 | shape(1,1) = 1 |
---|
| 727 | shape(2,1) = nlei-nldi+1 ! jpi |
---|
| 728 | shape(1,2) = 1 |
---|
| 729 | shape(2,2) = nlej-nldj+1 ! jpj |
---|
| 730 | shape(1,3) = 1 |
---|
| 731 | shape(2,3) = 1 |
---|
| 732 | ENDIF |
---|
| 733 | ! |
---|
| 734 | ! ----------------------------------------------------------------- |
---|
| 735 | ! ... Allocate memory for data exchange |
---|
| 736 | ! ----------------------------------------------------------------- |
---|
| 737 | ! |
---|
| 738 | ALLOCATE(exfld(shape(1,1):shape(2,1),shape(1,2):shape(2,2)), stat = ierror) |
---|
| 739 | IF (ierror > 0) THEN |
---|
| 740 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating exfld') |
---|
| 741 | RETURN |
---|
| 742 | ENDIF |
---|
| 743 | ! |
---|
| 744 | ! ... Announce send variables, all on T points. |
---|
| 745 | ! |
---|
| 746 | info = PRISM_Out |
---|
| 747 | ! |
---|
| 748 | |
---|
| 749 | IF ( commRank ) THEN |
---|
| 750 | |
---|
| 751 | DO ji = 1, nsend |
---|
| 752 | ! if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif |
---|
| 753 | CALL prism_def_var_proto (send_id(ji), cpl_send(ji), grid_id(1), & |
---|
| 754 | nodim, info, shape, data_type, ierror) |
---|
| 755 | IF ( ierror /= PRISM_Ok ) THEN |
---|
| 756 | PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji)) |
---|
| 757 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
| 758 | ENDIF |
---|
| 759 | ENDDO |
---|
| 760 | ! |
---|
| 761 | nodim(1) = 3 ! check |
---|
| 762 | nodim(2) = 0 |
---|
| 763 | ! |
---|
| 764 | ! ... Announce recv variables. |
---|
| 765 | ! |
---|
| 766 | info = PRISM_In |
---|
| 767 | ! |
---|
| 768 | ! ... a) on U points |
---|
| 769 | ! |
---|
| 770 | DO ji = 1, 4 |
---|
| 771 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
| 772 | nodim, info, shape, data_type, ierror) |
---|
| 773 | IF ( ierror /= PRISM_Ok ) THEN |
---|
| 774 | PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji)) |
---|
| 775 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
| 776 | ENDIF |
---|
| 777 | ENDDO |
---|
| 778 | ! |
---|
| 779 | ! ... b) on V points |
---|
| 780 | ! |
---|
| 781 | DO ji = 5, 8 |
---|
| 782 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
| 783 | nodim, info, shape, data_type, ierror) |
---|
| 784 | IF ( ierror /= PRISM_Ok ) THEN |
---|
| 785 | PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) |
---|
| 786 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
| 787 | ENDIF |
---|
| 788 | ENDDO |
---|
| 789 | ! |
---|
| 790 | ! ... c) on T points |
---|
| 791 | ! |
---|
| 792 | DO ji = 9, nrecv |
---|
| 793 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
| 794 | nodim, info, shape, data_type, ierror) |
---|
| 795 | IF ( ierror /= PRISM_Ok ) THEN |
---|
| 796 | PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) |
---|
| 797 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
| 798 | ENDIF |
---|
| 799 | ENDDO |
---|
| 800 | |
---|
| 801 | ENDIF ! commRank |
---|
| 802 | |
---|
| 803 | !------------------------------------------------------------------ |
---|
| 804 | ! 4th End of definition phase |
---|
| 805 | !------------------------------------------------------------------ |
---|
| 806 | |
---|
| 807 | IF ( commRank ) THEN |
---|
| 808 | CALL prism_enddef_proto(ierror) |
---|
| 809 | IF ( ierror /= PRISM_Ok ) & |
---|
| 810 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_enddef') |
---|
| 811 | ENDIF |
---|
| 812 | |
---|
| 813 | END SUBROUTINE cpl_prism_define |
---|
| 814 | |
---|
| 815 | |
---|
| 816 | |
---|
| 817 | SUBROUTINE cpl_prism_send( var_id, date, data_array, info ) |
---|
| 818 | |
---|
| 819 | IMPLICIT NONE |
---|
| 820 | |
---|
| 821 | !!--------------------------------------------------------------------- |
---|
| 822 | !! *** ROUTINE cpl_prism_send *** |
---|
| 823 | !! |
---|
| 824 | !! ** Purpose : - At each coupling time-step,this routine sends fields |
---|
| 825 | !! like sst or ice cover to the coupler or remote application. |
---|
| 826 | !!---------------------------------------------------------------------- |
---|
| 827 | !! * Arguments |
---|
| 828 | !! |
---|
| 829 | INTEGER, INTENT( IN ) :: var_id ! variable Id |
---|
| 830 | INTEGER, INTENT( OUT ) :: info ! OASIS3 info argument |
---|
| 831 | INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds |
---|
| 832 | REAL(wp) :: data_array(:,:) |
---|
| 833 | !! |
---|
| 834 | !! * Local declarations |
---|
| 835 | !! |
---|
| 836 | #if defined key_mpp_mpi |
---|
| 837 | REAL(wp) :: global_array(jpiglo,jpjglo) |
---|
| 838 | ! |
---|
| 839 | !mpi INTEGER :: status(MPI_STATUS_SIZE) |
---|
| 840 | !mpi INTEGER :: type ! MPI data type |
---|
| 841 | INTEGER :: request ! MPI isend request |
---|
| 842 | INTEGER :: ji, jj, jn ! local loop indicees |
---|
| 843 | #else |
---|
| 844 | INTEGER :: ji |
---|
| 845 | #endif |
---|
| 846 | !! |
---|
| 847 | !!-------------------------------------------------------------------- |
---|
| 848 | !! |
---|
| 849 | |
---|
| 850 | #if defined key_mpp_mpi |
---|
| 851 | |
---|
| 852 | request = 0 |
---|
| 853 | |
---|
| 854 | IF ( rootexchg ) THEN |
---|
| 855 | ! |
---|
| 856 | !mpi IF ( wp == 4 ) type = MPI_REAL |
---|
| 857 | !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION |
---|
| 858 | ! |
---|
| 859 | ! collect data on the local root process |
---|
| 860 | ! |
---|
| 861 | |
---|
| 862 | if ( var_id == 1 .and. localRank == localRoot .and. ln_ctl ) then |
---|
| 863 | do ji = 0, localSize-1 |
---|
| 864 | WRITE(numout,*) ' rootexchg: ranges for rank ', ji, ' are ', ranges(:,ji) |
---|
| 865 | enddo |
---|
| 866 | endif |
---|
| 867 | |
---|
| 868 | IF ( localRank /= localRoot ) THEN |
---|
| 869 | |
---|
| 870 | DO jj = nldj, nlej |
---|
| 871 | DO ji = nldi, nlei |
---|
| 872 | exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) |
---|
| 873 | ENDDO |
---|
| 874 | ENDDO |
---|
| 875 | |
---|
| 876 | !mpi CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror) |
---|
| 877 | CALL mppsend (localRank, exfld, range(5), localRoot, request) |
---|
| 878 | |
---|
| 879 | if ( var_id == 1 .and. ln_ctl ) then |
---|
| 880 | WRITE(numout,*) ' rootexchg: This is process ', localRank |
---|
| 881 | WRITE(numout,*) ' rootexchg: We have a range of ', range |
---|
| 882 | ! WRITE(numout,*) ' rootexchg: We got SST to process ', data_array |
---|
| 883 | endif |
---|
| 884 | |
---|
| 885 | ENDIF |
---|
| 886 | |
---|
| 887 | IF ( localRank == localRoot ) THEN |
---|
| 888 | |
---|
| 889 | DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 |
---|
| 890 | DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 |
---|
| 891 | global_array(ji,jj) = data_array(ji,jj) ! workaround |
---|
| 892 | ENDDO |
---|
| 893 | ENDDO |
---|
| 894 | |
---|
| 895 | DO jn = 1, localSize-1 |
---|
| 896 | |
---|
| 897 | !mpi CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror) |
---|
| 898 | CALL mpprecv(jn, buffer, ranges(5,jn)) |
---|
| 899 | |
---|
| 900 | if ( var_id == 1 .and. ln_ctl ) then |
---|
| 901 | WRITE(numout,*) ' rootexchg: Handling data from process ', jn |
---|
| 902 | ! WRITE(numout,*) ' rootexchg: We got SST to process ', buffer |
---|
| 903 | endif |
---|
| 904 | |
---|
| 905 | |
---|
| 906 | DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 |
---|
| 907 | DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 |
---|
| 908 | global_array(ji,jj) = buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1) |
---|
| 909 | ENDDO |
---|
| 910 | ENDDO |
---|
| 911 | |
---|
| 912 | ENDDO |
---|
| 913 | |
---|
| 914 | CALL prism_put_proto ( var_id, date, global_array, info ) |
---|
| 915 | |
---|
| 916 | ENDIF |
---|
| 917 | |
---|
| 918 | ELSE |
---|
| 919 | |
---|
| 920 | DO jj = nldj, nlej |
---|
| 921 | DO ji = nldi, nlei |
---|
| 922 | exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) |
---|
| 923 | ENDDO |
---|
| 924 | ENDDO |
---|
| 925 | |
---|
| 926 | CALL prism_put_proto ( var_id, date, exfld, info ) |
---|
| 927 | |
---|
| 928 | ENDIF |
---|
| 929 | |
---|
| 930 | #else |
---|
| 931 | |
---|
| 932 | ! |
---|
| 933 | ! send local data from every process to OASIS3 |
---|
| 934 | ! |
---|
| 935 | IF ( commRank ) & |
---|
| 936 | CALL prism_put_proto ( var_id, date, data_array, info ) |
---|
| 937 | |
---|
| 938 | #endif |
---|
| 939 | |
---|
| 940 | IF ( commRank ) THEN |
---|
| 941 | |
---|
| 942 | IF (ln_ctl .and. lwp) THEN |
---|
| 943 | |
---|
| 944 | IF ( info == PRISM_Sent .OR. & |
---|
| 945 | info == PRISM_ToRest .OR. & |
---|
| 946 | info == PRISM_SentOut .OR. & |
---|
| 947 | info == PRISM_ToRestOut ) THEN |
---|
| 948 | WRITE(numout,*) '****************' |
---|
| 949 | DO ji = 1, nsend |
---|
| 950 | IF (var_id == send_id(ji) ) THEN |
---|
| 951 | WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji) |
---|
| 952 | EXIT |
---|
| 953 | ENDIF |
---|
| 954 | ENDDO |
---|
| 955 | WRITE(numout,*) 'prism_put_proto: var_id ', var_id |
---|
| 956 | WRITE(numout,*) 'prism_put_proto: date ', date |
---|
| 957 | WRITE(numout,*) 'prism_put_proto: info ', info |
---|
| 958 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
| 959 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
| 960 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
| 961 | WRITE(numout,*) '****************' |
---|
| 962 | ENDIF |
---|
| 963 | |
---|
| 964 | ENDIF |
---|
| 965 | |
---|
| 966 | ENDIF |
---|
| 967 | |
---|
| 968 | END SUBROUTINE cpl_prism_send |
---|
| 969 | |
---|
| 970 | |
---|
| 971 | |
---|
| 972 | SUBROUTINE cpl_prism_recv( var_id, date, data_array, info ) |
---|
| 973 | |
---|
| 974 | IMPLICIT NONE |
---|
| 975 | |
---|
| 976 | !!--------------------------------------------------------------------- |
---|
| 977 | !! *** ROUTINE cpl_prism_recv *** |
---|
| 978 | !! |
---|
| 979 | !! ** Purpose : - At each coupling time-step,this routine receives fields |
---|
| 980 | !! like stresses and fluxes from the coupler or remote application. |
---|
| 981 | !!---------------------------------------------------------------------- |
---|
| 982 | !! * Arguments |
---|
| 983 | !! |
---|
| 984 | INTEGER, INTENT( IN ) :: var_id ! variable Id |
---|
| 985 | INTEGER, INTENT( OUT ) :: info ! variable Id |
---|
| 986 | INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds |
---|
| 987 | REAL(wp),INTENT( OUT ) :: data_array(:,:) |
---|
| 988 | !! |
---|
| 989 | !! * Local declarations |
---|
| 990 | !! |
---|
| 991 | #if defined key_mpp_mpi |
---|
| 992 | REAL(wp) :: global_array(jpiglo,jpjglo) |
---|
| 993 | ! |
---|
| 994 | ! LOGICAL :: action = .false. |
---|
| 995 | LOGICAL :: action |
---|
| 996 | !mpi INTEGER :: status(MPI_STATUS_SIZE) |
---|
| 997 | !mpi INTEGER :: type ! MPI data type |
---|
| 998 | INTEGER :: request ! MPI isend request |
---|
| 999 | INTEGER :: ji, jj, jn ! local loop indices |
---|
| 1000 | #else |
---|
| 1001 | INTEGER :: ji |
---|
| 1002 | #endif |
---|
| 1003 | !! |
---|
| 1004 | !!-------------------------------------------------------------------- |
---|
| 1005 | !! |
---|
| 1006 | #ifdef key_mpp_mpi |
---|
| 1007 | action = .false. |
---|
| 1008 | request = 0 |
---|
| 1009 | |
---|
| 1010 | IF ( rootexchg ) THEN |
---|
| 1011 | ! |
---|
| 1012 | ! receive data from OASIS3 on local root |
---|
| 1013 | ! |
---|
| 1014 | IF ( commRank ) & |
---|
| 1015 | CALL prism_get_proto ( var_id, date, global_array, info ) |
---|
| 1016 | |
---|
| 1017 | CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror ) |
---|
| 1018 | |
---|
| 1019 | ELSE |
---|
| 1020 | ! |
---|
| 1021 | ! receive local data from OASIS3 on every process |
---|
| 1022 | ! |
---|
| 1023 | CALL prism_get_proto ( var_id, date, exfld, info ) |
---|
| 1024 | |
---|
| 1025 | ENDIF |
---|
| 1026 | |
---|
| 1027 | IF ( info == PRISM_Recvd .OR. & |
---|
| 1028 | info == PRISM_FromRest .OR. & |
---|
| 1029 | info == PRISM_RecvOut .OR. & |
---|
| 1030 | info == PRISM_FromRestOut ) action = .true. |
---|
| 1031 | |
---|
| 1032 | IF (ln_ctl .and. lwp) THEN |
---|
| 1033 | WRITE(numout,*) "info", info, var_id |
---|
| 1034 | WRITE(numout,*) "date", date, var_id |
---|
| 1035 | WRITE(numout,*) "action", action, var_id |
---|
| 1036 | ENDIF |
---|
| 1037 | |
---|
| 1038 | IF ( rootexchg .and. action ) THEN |
---|
| 1039 | ! |
---|
| 1040 | !mpi IF ( wp == 4 ) type = MPI_REAL |
---|
| 1041 | !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION |
---|
| 1042 | ! |
---|
| 1043 | ! distribute data to processes |
---|
| 1044 | ! |
---|
| 1045 | IF ( localRank == localRoot ) THEN |
---|
| 1046 | |
---|
| 1047 | DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 |
---|
| 1048 | DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 |
---|
| 1049 | exfld(ji-ranges(1,localRoot)+1,jj-ranges(3,localRoot)+1) = global_array(ji,jj) |
---|
| 1050 | ENDDO |
---|
| 1051 | ENDDO |
---|
| 1052 | |
---|
| 1053 | DO jn = 1, localSize-1 |
---|
| 1054 | |
---|
| 1055 | DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 |
---|
| 1056 | DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 |
---|
| 1057 | buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1) = global_array(ji,jj) |
---|
| 1058 | ENDDO |
---|
| 1059 | ENDDO |
---|
| 1060 | |
---|
| 1061 | !mpi CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror) |
---|
| 1062 | CALL mppsend (jn, buffer, ranges(5,jn), jn, request) |
---|
| 1063 | |
---|
| 1064 | ENDDO |
---|
| 1065 | |
---|
| 1066 | ENDIF |
---|
| 1067 | |
---|
| 1068 | IF ( localRank /= localRoot ) THEN |
---|
| 1069 | !mpi CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror) |
---|
| 1070 | CALL mpprecv(localRank, exfld, range(5)) |
---|
| 1071 | ENDIF |
---|
| 1072 | |
---|
| 1073 | ENDIF |
---|
| 1074 | |
---|
| 1075 | IF ( action ) THEN |
---|
| 1076 | |
---|
| 1077 | data_array = 0.0 |
---|
| 1078 | |
---|
| 1079 | DO jj = nldj, nlej |
---|
| 1080 | DO ji = nldi, nlei |
---|
| 1081 | data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1) |
---|
| 1082 | ENDDO |
---|
| 1083 | ENDDO |
---|
| 1084 | |
---|
| 1085 | IF (ln_ctl .and. lwp) THEN |
---|
| 1086 | WRITE(numout,*) '****************' |
---|
| 1087 | DO ji = 1, nrecv |
---|
| 1088 | IF (var_id == recv_id(ji) ) THEN |
---|
| 1089 | WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji) |
---|
| 1090 | EXIT |
---|
| 1091 | ENDIF |
---|
| 1092 | ENDDO |
---|
| 1093 | WRITE(numout,*) 'prism_get_proto: var_id ', var_id |
---|
| 1094 | WRITE(numout,*) 'prism_get_proto: date ', date |
---|
| 1095 | WRITE(numout,*) 'prism_get_proto: info ', info |
---|
| 1096 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
| 1097 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
| 1098 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
| 1099 | WRITE(numout,*) '****************' |
---|
| 1100 | ENDIF |
---|
| 1101 | |
---|
| 1102 | ENDIF |
---|
| 1103 | #else |
---|
| 1104 | CALL prism_get_proto ( var_id, date, exfld, info) |
---|
| 1105 | |
---|
| 1106 | IF (info == PRISM_Recvd .OR. & |
---|
| 1107 | info == PRISM_FromRest .OR. & |
---|
| 1108 | info == PRISM_RecvOut .OR. & |
---|
| 1109 | info == PRISM_FromRestOut ) THEN |
---|
| 1110 | data_array = exfld |
---|
| 1111 | |
---|
| 1112 | IF (ln_ctl .and. lwp ) THEN |
---|
| 1113 | WRITE(numout,*) '****************' |
---|
| 1114 | DO ji = 1, nrecv |
---|
| 1115 | IF (var_id == recv_id(ji) ) THEN |
---|
| 1116 | WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji) |
---|
| 1117 | EXIT |
---|
| 1118 | ENDIF |
---|
| 1119 | ENDDO |
---|
| 1120 | WRITE(numout,*) 'prism_get_proto: var_id ', var_id |
---|
| 1121 | WRITE(numout,*) 'prism_get_proto: date ', date |
---|
| 1122 | WRITE(numout,*) 'prism_get_proto: info ', info |
---|
| 1123 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
| 1124 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
| 1125 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
| 1126 | WRITE(numout,*) '****************' |
---|
| 1127 | ENDIF |
---|
| 1128 | |
---|
| 1129 | ENDIF |
---|
| 1130 | #endif |
---|
| 1131 | |
---|
| 1132 | END SUBROUTINE cpl_prism_recv |
---|
| 1133 | |
---|
| 1134 | |
---|
| 1135 | |
---|
| 1136 | SUBROUTINE cpl_prism_finalize |
---|
| 1137 | |
---|
| 1138 | IMPLICIT NONE |
---|
| 1139 | |
---|
| 1140 | !!--------------------------------------------------------------------- |
---|
| 1141 | !! *** ROUTINE cpl_prism_finalize *** |
---|
| 1142 | !! |
---|
| 1143 | !! ** Purpose : - Finalizes the coupling. If MPI_init has not been |
---|
| 1144 | !! called explicitly before cpl_prism_init it will also close |
---|
| 1145 | !! MPI communication. |
---|
| 1146 | !!---------------------------------------------------------------------- |
---|
| 1147 | |
---|
| 1148 | DEALLOCATE(exfld) |
---|
| 1149 | |
---|
| 1150 | if ( prism_was_initialized ) then |
---|
| 1151 | |
---|
| 1152 | if ( prism_was_terminated ) then |
---|
| 1153 | print *, 'prism has already been terminated.' |
---|
| 1154 | else |
---|
| 1155 | call prism_terminate_proto ( ierror ) |
---|
| 1156 | prism_was_terminated = .true. |
---|
| 1157 | endif |
---|
| 1158 | |
---|
| 1159 | else |
---|
| 1160 | |
---|
| 1161 | print *, 'Initialize prism before terminating it.' |
---|
| 1162 | |
---|
| 1163 | endif |
---|
| 1164 | |
---|
| 1165 | |
---|
| 1166 | END SUBROUTINE cpl_prism_finalize |
---|
| 1167 | |
---|
| 1168 | #endif |
---|
| 1169 | |
---|
| 1170 | END MODULE cpl_oasis3 |
---|