- Timestamp:
- 2019-09-06T18:07:34+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0_new_runoff_coupling/src/OCE/SBC/cpl_oasis3.F90
r10888 r11509 29 29 #endif 30 30 USE par_oce ! ocean parameters 31 USE cpl_rnf_1d, ONLY: nn_cpl_river ! Variables used in 1D river outflow 31 32 USE dom_oce ! ocean space and time domain 32 33 USE in_out_manager ! I/O manager … … 35 36 IMPLICIT NONE 36 37 PRIVATE 38 39 #if ! defined key_oasis3 40 ! Dummy interface to oasis_get if not using oasis 41 INTERFACE oasis_get 42 MODULE PROCEDURE oasis_get_1d, oasis_get_2d 43 END INTERFACE 44 #endif 37 45 38 46 PUBLIC cpl_init … … 40 48 PUBLIC cpl_snd 41 49 PUBLIC cpl_rcv 50 PUBLIC cpl_rcv_1d 42 51 PUBLIC cpl_freq 43 52 PUBLIC cpl_finalize … … 81 90 INTEGER :: nct ! Number of categories in field 82 91 INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received 92 INTEGER :: dimensions ! Number of dimensions of coupling field 83 93 END TYPE FLD_CPL 84 94 … … 141 151 ! 142 152 INTEGER :: id_part 153 INTEGER :: id_part_0d ! Partition for 0d fields 154 INTEGER :: id_part_rnf_1d ! Partition for 1d river outflow fields 155 INTEGER :: id_part_temp ! Temperary partition used to choose either 0d or 1d partitions 143 156 INTEGER :: paral(5) ! OASIS3 box partition 144 INTEGER :: ishape(4) ! shape of arrays passed to PSMILe 157 INTEGER :: ishape(4) ! shape of 2D arrays passed to PSMILe 158 INTEGER :: ishape0d1d(2) ! Shape of 0D or 1D arrays passed to PSMILe. 159 INTEGER :: var_nodims(2) ! Number of coupling field dimensions. 160 ! var_nodims(1) is redundant from OASIS3-MCT vn4.0 onwards 161 ! but retained for backward compatibility. 162 ! var_nodims(2) is the number of fields in a bundle 163 ! or 1 for unbundled fields (bundles are not yet catered for 164 ! in NEMO hence we default to 1). 145 165 INTEGER :: ji,jc,jm ! local loop indicees 146 166 CHARACTER(LEN=64) :: zclname … … 185 205 ishape(3) = 1 186 206 ishape(4) = nlej-nldj+1 207 208 ishape0d1d(1) = 0 209 ishape0d1d(2) = 0 187 210 ! 188 211 ! ... Allocate memory for data exchange … … 211 234 212 235 CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo ) 236 237 ! A special partition is needed for 0D fields 238 239 paral(1) = 0 ! serial partitioning 240 paral(2) = 0 241 IF ( nproc == 0) THEN 242 paral(3) = 1 ! Size of array to couple (scalar) 243 ELSE 244 paral(3) = 0 ! Dummy size for PE's not involved 245 END IF 246 paral(4) = 0 247 paral(5) = 0 248 249 CALL oasis_def_partition ( id_part_0d, paral, nerror, 1 ) 250 251 ! Another partition is needed for 1D river routing fields 252 253 paral(1) = 0 ! serial partitioning 254 paral(2) = 0 255 IF ( nproc == 0) THEN 256 paral(3) = nn_cpl_river ! Size of array to couple (vector) 257 ELSE 258 paral(3) = 0 ! Dummy size for PE's not involved 259 END IF 260 paral(4) = 0 261 paral(5) = 0 262 263 264 CALL oasis_def_partition ( id_part_rnf_1d, paral, nerror, nn_cpl_river ) 265 213 266 ! 214 267 ! ... Announce send variables. … … 244 297 #endif 245 298 IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out 246 CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & 299 300 ! 301 ! ... Set the field dimension and bundle count 302 var_nodims(1) = 2 303 var_nodims(2) = 1 ! Modify this value to cater for bundled fields. 304 305 CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , var_nodims, & 247 306 & OASIS_Out , ishape , OASIS_REAL, nerror ) 248 307 IF ( nerror /= OASIS_Ok ) THEN … … 289 348 #endif 290 349 IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In 291 CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & 292 & OASIS_In , ishape , OASIS_REAL, nerror ) 350 flush(numout) 351 352 ! Define 0D (Greenland or Antarctic ice mass) or 1D (river outflow) coupling fields 353 IF (srcv(ji)%dimensions <= 1) THEN 354 var_nodims(1) = 1 355 var_nodims(2) = 1 ! Modify this value to cater for bundled fields. 356 IF (nproc == 0) THEN 357 358 IF (srcv(ji)%dimensions == 0) THEN 359 360 ! If 0D then set temporary variables to 0D components 361 id_part_temp = id_part_0d 362 ishape0d1d(2) = 1 363 ELSE 364 365 ! If 1D then set temporary variables to river outflow components 366 id_part_temp = id_part_rnf_1d 367 ishape0d1d(2)= nn_cpl_river 368 369 END IF 370 371 CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part_temp , var_nodims, & 372 OASIS_In , ishape0d1d(1:2) , OASIS_REAL, nerror ) 373 ELSE 374 ! Dummy call to keep OASIS3-MCT happy. 375 CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part_0d , var_nodims, & 376 OASIS_In , ishape0d1d(1:2) , OASIS_REAL, nerror ) 377 END IF 378 ELSE 379 ! It's a "normal" 2D (or pseudo 3D) coupling field. 380 ! ... Set the field dimension and bundle count 381 var_nodims(1) = 2 382 var_nodims(2) = 1 ! Modify this value to cater for bundled fields. 383 384 CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , var_nodims, & 385 OASIS_In , ishape , OASIS_REAL, nerror ) 386 ENDIF 387 293 388 IF ( nerror /= OASIS_Ok ) THEN 294 389 WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) … … 465 560 466 561 562 SUBROUTINE cpl_rcv_1d( kid, kstep, pdata, nitems, kinfo ) 563 !!--------------------------------------------------------------------- 564 !! *** ROUTINE cpl_rcv_1d *** 565 !! 566 !! ** Purpose : - A special version of cpl_rcv to deal exclusively with 567 !! receipt of 0D or 1D fields. 568 !! The fields are recieved into a 1D array buffer which is simply a 569 !! dynamically sized sized array (which may be of size 1) 570 !! of 0 dimensional fields. This allows us to pass miltiple 0D 571 !! fields via a single put/get operation. 572 !!---------------------------------------------------------------------- 573 INTEGER , INTENT(in ) :: nitems ! Number of 0D items to recieve 574 ! during this get operation. i.e. 575 ! The size of the 1D array in which 576 ! 0D items are passed. 577 INTEGER , INTENT(in ) :: kid ! ID index of the incoming 578 ! data. 579 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 580 REAL(wp), INTENT(inout) :: pdata(1:nitems) ! The original value(s), 581 ! unchanged if nothing is 582 ! received 583 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 584 !! 585 REAL(wp) :: recvfld(1:nitems) ! Local receive field buffer 586 INTEGER :: jc,jm ! local loop index 587 INTEGER :: ierr 588 LOGICAL :: llaction 589 INTEGER :: MPI_WORKING_PRECISION 590 INTEGER :: number_to_print 591 !!-------------------------------------------------------------------- 592 ! 593 ! receive local data from OASIS3 on every process 594 ! 595 kinfo = OASIS_idle 596 ! 597 ! 0D and 1D fields won't have categories or any other form of "pseudo level" 598 ! so we only cater for a single set of values and thus don't bother 599 ! with a loop over the jc index 600 jc = 1 601 602 DO jm = 1, srcv(kid)%ncplmodel 603 604 IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN 605 606 IF ( ( srcv(kid)%dimensions <= 1) .AND. (nproc == 0) ) THEN 607 ! Since there is no concept of data decomposition for zero 608 ! dimension fields, they must only be exchanged through the master PE, 609 ! unlike "normal" 2D field cases where every PE is involved. 610 611 CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, recvfld, kinfo ) 612 613 llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. & 614 kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut 615 616 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , & 617 llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 618 619 IF ( llaction ) THEN 620 621 kinfo = OASIS_Rcv 622 pdata(1:nitems) = recvfld(1:nitems) 623 624 IF ( ln_ctl ) THEN 625 number_to_print = 10 626 IF ( nitems < number_to_print ) number_to_print = nitems 627 WRITE(numout,*) '****************' 628 WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname 629 WRITE(numout,*) 'oasis_get: ivarid ' , srcv(kid)%nid(jc,jm) 630 WRITE(numout,*) 'oasis_get: kstep', kstep 631 WRITE(numout,*) 'oasis_get: info ', kinfo 632 WRITE(numout,*) ' - Minimum Value is ', MINVAL(pdata(:)) 633 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:)) 634 WRITE(numout,*) ' - Start of data is ', pdata(1:number_to_print) 635 WRITE(numout,*) '****************' 636 ENDIF 637 638 ENDIF 639 ENDIF 640 ENDIF 641 642 ENDDO 643 644 ! Set the precision that we want to broadcast using MPI_BCAST 645 SELECT CASE( wp ) 646 CASE( sp ) 647 MPI_WORKING_PRECISION = MPI_REAL ! Single precision 648 CASE( dp ) 649 MPI_WORKING_PRECISION = MPI_DOUBLE_PRECISION ! Double precision 650 CASE default 651 CALL oasis_abort( ncomp_id, "cpl_rcv_1d", "Could not find precision for coupling 0d or 1d field" ) 652 END SELECT 653 654 ! We have to broadcast (potentially) received values from PE 0 to all 655 ! the others. If no new data has been received we're just 656 ! broadcasting the existing values but there's no more efficient way 657 ! to deal with that w/o NEMO adopting a UM-style test mechanism 658 ! to determine active put/get timesteps. 659 CALL mpi_bcast( pdata, nitems, MPI_WORKING_PRECISION, localRoot, mpi_comm_opa, ierr ) 660 661 ! 662 END SUBROUTINE cpl_rcv_1d 663 664 467 665 INTEGER FUNCTION cpl_freq( cdfieldname ) 468 666 !!--------------------------------------------------------------------- … … 572 770 SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7) 573 771 CHARACTER(*), INTENT(in ) :: cd1 574 INTEGER , INTENT(in ) :: k2,k3(2),k4,k5( 2,2),k6772 INTEGER , INTENT(in ) :: k2,k3(2),k4,k5(*),k6 575 773 INTEGER , INTENT( out) :: k1,k7 576 774 k1 = -1 ; k7 = -1 … … 592 790 END SUBROUTINE oasis_put 593 791 594 SUBROUTINE oasis_get(k1,k2,p1,k3) 792 SUBROUTINE oasis_get_1d(k1,k2,p1,k3) 793 REAL(wp), DIMENSION(:) , INTENT( out) :: p1 794 INTEGER , INTENT(in ) :: k1,k2 795 INTEGER , INTENT( out) :: k3 796 p1(1) = -1. ; k3 = -1 797 WRITE(numout,*) 'oasis_get_1d: Error you sould not be there...' 798 END SUBROUTINE oasis_get_1d 799 800 SUBROUTINE oasis_get_2d(k1,k2,p1,k3) 595 801 REAL(wp), DIMENSION(:,:), INTENT( out) :: p1 596 802 INTEGER , INTENT(in ) :: k1,k2 597 803 INTEGER , INTENT( out) :: k3 598 804 p1(1,1) = -1. ; k3 = -1 599 WRITE(numout,*) 'oasis_get : Error you sould not be there...'600 END SUBROUTINE oasis_get 805 WRITE(numout,*) 'oasis_get_2d: Error you sould not be there...' 806 END SUBROUTINE oasis_get_2d 601 807 602 808 SUBROUTINE oasis_get_freqs(k1,k5,k2,k3,k4)
Note: See TracChangeset
for help on using the changeset viewer.
