frame/module_cpl.F

   1 MODULE module_cpl
   2
   3    USE module_domain          , ONLY : domain, get_ijk_from_grid
   4    USE module_configure       , ONLY : grid_config_rec_type
   5    USE module_model_constants , ONLY : stbolt
   6    USE module_driver_constants, ONLY : max_domains, max_cplfld, max_extdomains
   7    USE module_cpl_oasis3
   8
   9    IMPLICIT NONE
  10    PRIVATE
  11
  12    PUBLIC cpl_init
  13    PUBLIC cpl_set_dm_communicator
  14    PUBLIC cpl_defdomain
  15    PUBLIC cpl_settime
  16    PUBLIC cpl_snd
  17    PUBLIC cpl_rcv
  18    PUBLIC cpl_store_input
  19    PUBLIC cpl_finalize
  20    PUBLIC cpl_abort
  21
  22 #ifdef key_cpp_oasis3
  23    LOGICAL     , PARAMETER, PUBLIC :: coupler_on = .TRUE.
  24    CHARACTER(5), PARAMETER         :: coupler_name = 'oasis'
  25 #else
  26    LOGICAL     , PARAMETER, PUBLIC :: coupler_on = .FALSE.
  27    CHARACTER(4), PARAMETER         :: coupler_name = 'none'
  28 #endif
  29    INTEGER :: nsecrun             ! current time in seconds since simulation restart
  30    INTEGER, PARAMETER :: charlen = 64
  31    CHARACTER(charlen), DIMENSION(max_domains,max_extdomains,max_cplfld) :: rcvname, sndname   ! coupling fields names for each nest
  32
  33    CHARACTER(256) :: cltxt        ! messages or debug string
  34    INTEGER :: nlevdbg  = 1        ! verbosity level
  35    INTEGER :: nlevdbg2 = 10       ! verbosity level
  36
  37 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
  38    INCLUDE 'mpif.h'               ! only for MPI_COMM_NULL
  39 #else
  40    INTEGER :: MPI_COMM_NULL = -1  ! define a fake (and not used) MPI_COMM_NULL, so it is compiling
  41 #endif
  42
  43 CONTAINS
  44
  45    SUBROUTINE cpl_init( kl_comm )
  46       !!-------------------------------------------------------------------
  47       !!             ***  ROUTINE cpl_init  ***
  48       !!
  49       !! ** Purpose :   initialise coupling field names and WRF-coupler MPI communications
  50       !!--------------------------------------------------------------------
  51       INTEGER, INTENT(OUT) :: kl_comm       ! local MPI communicator of the model
  52       !
  53       INTEGER       :: jwrf,jext,jfld       ! local loop indicees
  54       CHARACTER( 3) :: clwrfdom, clextdom   ! d<domain>
  55       CHARACTER(16) :: clprefix             ! 'WRF_d??_EXT_d??_'
  56       !!--------------------------------------------------------------------
  57
  58       ! coupling field name default definition
  59       rcvname(:,:,:) = 'not defined'
  60       sndname(:,:,:) = 'not defined'
  61
  62       ! we could imagine to define rcvname and sndname through the namelist...
  63       ! define all possible coupling names with _d<domain> of WRF and the external model(s)
  64       DO jext = 1, max_extdomains
  65
  66          WRITE(clextdom, fmt="('d',i2.2)") jext
  67
  68          DO jwrf = 1, max_domains
  69
  70             WRITE(clwrfdom, fmt="('d',i2.2)") jwrf
  71             ! do not change following syntaxe as it is used in routines bellow
  72             clprefix = 'WRF_'//clwrfdom//'_EXT_'//clextdom//'_'
  73
  74             ! Variables that can be received by WRF
  75             rcvname(jwrf,jext,1) = clprefix//'SST'                  ! receive Sea surface temperature
  76             rcvname(jwrf,jext,2) = clprefix//'UOCE'                 ! receive ocean zonal surface current
  77             rcvname(jwrf,jext,3) = clprefix//'VOCE'                 ! receive ocean meridional surface current
  78
  79             ! Variables that can be sent by WRF
  80             sndname(jwrf,jext,1) = clprefix//'EVAP-PRECIP'          ! send net fresh water budget: evaporation - total precipitation
  81             sndname(jwrf,jext,2) = clprefix//'SURF_NET_SOLAR'       ! send net short wave flux at ground surface
  82             sndname(jwrf,jext,3) = clprefix//'SURF_NET_NON-SOLAR'   ! send net non-solar heat flux at ground surface
  83             sndname(jwrf,jext,4) = clprefix//'TAUX'                 ! send zonal wind tress at atmosphere-ocean interface
  84             sndname(jwrf,jext,5) = clprefix//'TAUY'                 ! send meridional wind tress at atmosphere-ocean interface
  85             sndname(jwrf,jext,6) = clprefix//'TAUMOD'               ! send the wind tress module at atmosphere-ocean interface
  86
  87          END DO
  88       END DO
  89
  90       IF ( coupler_name == 'oasis' ) CALL cpl_oasis_init( kl_comm )
  91
  92    END SUBROUTINE cpl_init
  93
  94
  95    SUBROUTINE cpl_set_dm_communicator( kdm_comm )
  96       !!-------------------------------------------------------------------
  97       !!             ***  SUBROUTINE cpl_initquilt  ***
  98       !!
  99       !! ** Purpose : provide the computing nodes communicator to the coupler
 100       !!--------------------------------------------------------------------
 101       INTEGER, INTENT(IN) :: kdm_comm       ! MPI communicator between the computing nodes
 102       !!--------------------------------------------------------------------
 103
 104       IF ( coupler_name == 'oasis' ) THEN
 105          IF ( kdm_comm == MPI_COMM_NULL ) THEN
 106             CALL cpl_oasis_define( sndname, rcvname )   ! define io_quilting to OASIS
 107          ELSE
 108             CALL cpl_oasis_def_dmcomm( kdm_comm )       ! send the computing nodes communicator to OASIS
 109          END IF
 110       END IF
 111
 112    END SUBROUTINE cpl_set_dm_communicator
 113
 114
 115    SUBROUTINE cpl_defdomain( grid )
 116       !!-------------------------------------------------------------------
 117       !!             ***  SUBROUTINE cpl_defdomain  ***
 118       !!
 119       !! ** Purpose : define each variable involved in the coupling and the grid partitioning
 120       !!--------------------------------------------------------------------
 121       TYPE(domain), INTENT(IN), POINTER ::   grid
 122       !
 123       INTEGER :: jwrf,jext,jfld          ! local loop indicees
 124       REAL    :: zmin,zmax               ! min/max of grid*cplmask
 125       INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
 126       INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor
 127       INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
 128       !!--------------------------------------------------------------------
 129 #if (EM_CORE == 1)
 130
 131       CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
 132          &                          ims, ime, jms, jme, kms, kme, &
 133          &                          ips, ipe, jps, jpe, kps, kpe  )
 134
 135       ! first do some checks and prints. note that this could not be done in cpl_init
 136       ! which is called too early in the code
 137
 138       ! some control prints on potential sent/received fields...
 139       CALL wrf_debug(nlevdbg, 'cpl_init: defined variables to be potentially received' )
 140       DO jfld = 1, max_cplfld
 141          DO jext = 1, grid%num_ext_model_couple_dom
 142             DO jwrf = 1, grid%max_dom
 143                IF( TRIM(sndname(jwrf,jext,jfld)) /= 'not defined' ) THEN
 144                   WRITE(cltxt,*) '   jwrf, jext, jfld: ', jwrf, jext, jfld ,' name: ', TRIM(sndname(jwrf,jext,jfld))
 145                   CALL wrf_debug(nlevdbg2, cltxt)
 146                END IF
 147             END DO
 148          END DO
 149       END DO
 150       CALL wrf_debug(nlevdbg, 'cpl_init: defined variables to be potentially sent' )
 151       DO jfld = 1, max_cplfld
 152          DO jext = 1, grid%num_ext_model_couple_dom
 153             DO jwrf = 1, grid%max_dom
 154                IF( TRIM(rcvname(jwrf,jext,jfld)) /= 'not defined' ) THEN
 155                   WRITE(cltxt,*) '   jwrf, jext, jfld: ', jwrf, jext, jfld ,' name: ', TRIM(rcvname(jwrf,jext,jfld))
 156                   CALL wrf_debug(nlevdbg2, cltxt)
 157                END IF
 158             END DO
 159          END DO
 160       END DO
 161
 162       ! some checks on grid%cplmask...
 163       DO jext = 1, grid%num_ext_model_couple_dom
 164
 165          WRITE(cltxt,*) 'checks on cplmask of external model domain: ', jext               ;   CALL wrf_debug(nlevdbg, cltxt)
 166
 167          zmin = MINVAL(grid%cplmask(ips:ipe,jext,jps:jpe))
 168          IF( zmin < 0. ) THEN
 169             WRITE(cltxt,*) 'min of external model domain cplmask: ',jext,' < 0. : ',zmin   ;   CALL cpl_abort('cpl_defdomain',cltxt)
 170          END IF
 171          WRITE(cltxt,*) '   minval(grid%cplmask(ips:ipe,jext,jps:jpe)): ', zmin            ;   CALL wrf_debug(nlevdbg, cltxt)
 172
 173          zmax = MAXVAL(grid%cplmask(ips:ipe,jext,jps:jpe))
 174          IF( zmax > 1. ) THEN
 175             WRITE(cltxt,*) 'max of external model domain cplmask: ',jext,' > 1. : ',zmax   ;   CALL cpl_abort('cpl_defdomain',cltxt)
 176          END IF
 177          IF( zmax == 0. ) THEN
 178             WRITE(cltxt,*) 'max of external model domain cplmask: ',jext,' = 0 '           ;   CALL wrf_message(cltxt)
 179             WRITE(cltxt,*) '  => no coupling between this external model domain and this WRF patch'   ;   CALL wrf_message(cltxt)
 180          END IF
 181          WRITE(cltxt,*) '   maxval(grid%cplmask(ips:ipe,jext,jps:jpe)): ', zmax            ;   CALL wrf_debug(nlevdbg, cltxt)
 182
 183       END DO
 184 #endif
 185
 186       IF ( coupler_name == 'oasis' ) CALL cpl_oasis_define( sndname, rcvname, grid )
 187
 188    END SUBROUTINE cpl_defdomain
 189
 190
 191    SUBROUTINE cpl_settime( psec )
 192       !!-------------------------------------------------------------------
 193       !!             ***  SUBROUTINE cpl_settime  ***
 194       !!
 195       !! ** Purpose :   update and store the number of second since the beginning of the job.
 196       !!--------------------------------------------------------------------
 197       REAL, INTENT(in) :: psec
 198       !!--------------------------------------------------------------------
 199
 200       nsecrun = NINT( psec )
 201       WRITE(cltxt,*) 'store number of second since the beginning of the job: ', nsecrun   ;   CALL wrf_debug(nlevdbg2, cltxt)
 202
 203    END SUBROUTINE cpl_settime
 204
 205
 206    FUNCTION cpl_toreceive( kdomwrf, kdomext, kfldid )
 207       !!-------------------------------------------------------------------
 208       !!             ***  FUNCTION cpl_toreceive  ***
 209       !!
 210       !! ** Purpose :   send back a logical to tell if a variable must be received or not
 211       !!--------------------------------------------------------------------
 212       INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
 213       INTEGER, INTENT(IN) :: kdomext   ! external model domain index
 214       INTEGER, INTENT(IN) :: kfldid    ! field index
 215       !
 216       LOGICAL :: cpl_toreceive
 217       !!--------------------------------------------------------------------
 218
 219       IF ( coupler_name == 'oasis' ) cpl_toreceive = cpl_oasis_toreceive( kdomwrf, kdomext, kfldid )
 220
 221    END FUNCTION cpl_toreceive
 222
 223
 224    FUNCTION cpl_tosend( kdomwrf, kfldid, max_edom )
 225       !!-------------------------------------------------------------------
 226       !!             ***  FUNCTION cpl_tosend  ***
 227       !!
 228       !! ** Purpose :   send back a logical array to tell if a variable must be
 229       !!                sent or not to each of the external model domains
 230       !!--------------------------------------------------------------------
 231       INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
 232       INTEGER, INTENT(IN) :: kfldid    ! variable index
 233       INTEGER, INTENT(IN) :: max_edom  ! max number of external model domains
 234       !
 235       LOGICAL,DIMENSION(max_edom) :: cpl_tosend
 236       INTEGER                     :: jext          ! local loop indicees
 237       !!--------------------------------------------------------------------
 238
 239       DO jext = 1, max_edom
 240          IF ( coupler_name == 'oasis' )   cpl_tosend(jext) = cpl_oasis_tosend( kdomwrf, jext, kfldid )
 241       END DO
 242
 243    END FUNCTION cpl_tosend
 244
 245
 246    FUNCTION cpl_get_fldid( cdsuffix )
 247       !!-------------------------------------------------------------------
 248       !!             ***  SUBROUTINE cpl_get_fldid  ***
 249       !!
 250       !! ** Purpose : send back the field id corresponding to the suffix of a coupling variable name
 251       !!--------------------------------------------------------------------
 252       CHARACTER(*), INTENT(IN) :: cdsuffix   ! field name suffix
 253       !
 254       INTEGER       :: cpl_get_fldid     ! field index
 255       INTEGER       :: jfld              ! local loop indicees
 256       CHARACTER(16) :: clprefix          ! 'WRF_d01_EXT_d01_'
 257       !!--------------------------------------------------------------------
 258       cpl_get_fldid = -1   ! default value
 259
 260       clprefix = 'WRF_d01_EXT_d01_'
 261       DO jfld = 1, max_cplfld
 262          IF( clprefix//TRIM(cdsuffix) == TRIM(sndname(1,1,jfld)) )   cpl_get_fldid = jfld
 263          IF( clprefix//TRIM(cdsuffix) == TRIM(rcvname(1,1,jfld)) )   cpl_get_fldid = jfld
 264       END DO
 265
 266       IF( cpl_get_fldid == -1 )   CALL cpl_abort( 'cpl_get_fldid', 'variable suffix not found '//TRIM(cdsuffix) )
 267       WRITE(cltxt,*) 'The id of variable'//TRIM(cdsuffix)//' is: ', cpl_get_fldid   ;   CALL wrf_debug(nlevdbg2, cltxt)
 268
 269    END FUNCTION cpl_get_fldid
 270
 271
 272    SUBROUTINE cpl_snd( grid )
 273          !!-------------------------------------------------------------------
 274       !!             ***  SUBROUTINE cpl_snd  ***
 275       !!
 276       !! ** Purpose : compute coupling data to be sent and call cpl_sndfield
 277       !!--------------------------------------------------------------------
 278       TYPE(domain), INTENT(IN), POINTER :: grid
 279       !
 280       INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
 281       INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor
 282       INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
 283       !!--------------------------------------------------------------------
 284       CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
 285          &                          ims, ime, jms, jme, kms, kme, &
 286          &                          ips, ipe, jps, jpe, kps, kpe  )
 287
 288 #if (EM_CORE == 1)
 289       CALL cpl_snd2( grid, grid%num_ext_model_couple_dom,   &
 290          &                 ids, ide, jds, jde, kds, kde,    &
 291          &                 ims, ime, jms, jme, kms, kme,    &
 292          &                 ips, ipe, jps, jpe, kps, kpe )
 293 #endif
 294
 295    END SUBROUTINE cpl_snd
 296
 297
 298    SUBROUTINE cpl_snd2( grid, max_edom                &
 299       &                     , ids,ide,jds,jde,kds,kde &
 300       &                     , ims,ime,jms,jme,kms,kme &
 301       &                     , ips,ipe,jps,jpe,kps,kpe )
 302       !!-------------------------------------------------------------------
 303       !!             ***  SUBROUTINE cpl_snd2  ***
 304       !!
 305       !! ** Purpose : compute coupling data to be sent and call cpl_sndfield
 306       !!--------------------------------------------------------------------
 307       TYPE(domain), INTENT(IN), POINTER :: grid
 308       INTEGER,      INTENT(IN)          :: max_edom    ! max number of external model domains
 309       INTEGER,      INTENT(IN)          :: ids,ide,jds,jde,kds,kde
 310       INTEGER,      INTENT(IN)          :: ims,ime,jms,jme,kms,kme
 311       INTEGER,      INTENT(IN)          :: ips,ipe,jps,jpe,kps,kpe
 312       !
 313       REAL, DIMENSION( ips:ipe, jps:jpe ) :: cplsnd
 314       REAL, DIMENSION( ips:ipe, jps:jpe ) :: u_uo
 315       REAL, DIMENSION( ips:ipe, jps:jpe ) :: v_vo
 316       REAL, DIMENSION( ips:ipe, jps:jpe ) :: wspd
 317       REAL, DIMENSION( ips:ipe, jps:jpe ) :: taut
 318       INTEGER :: icnt
 319       INTEGER :: ifldid
 320       LOGICAL,DIMENSION(max_edom) :: lltosend
 321       !!--------------------------------------------------------------------
 322
 323 #if (EM_CORE == 1)
 324
 325       ! we use ipe and not min(ipe, ide-1) the variable we are using are coming from grid and are therefore initialized to 0
 326
 327       ifldid      = cpl_get_fldid( 'EVAP-PRECIP' )
 328       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 329       IF ( COUNT(lltosend) > 0 ) THEN
 330          cplsnd(ips:ipe,jps:jpe) = grid%QFX(ips:ipe,jps:jpe) &
 331             &                  - ( grid%RAINCV(ips:ipe,jps:jpe)+grid%RAINNCV(ips:ipe,jps:jpe) ) / grid%DT
 332          CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
 333       END IF
 334
 335       ifldid      = cpl_get_fldid( 'SURF_NET_SOLAR' )
 336       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 337       IF ( COUNT(lltosend) > 0 ) THEN
 338          CALL cpl_sndfield( grid%id, lltosend, ifldid, grid%GSW(ips:ipe,jps:jpe) )
 339       END IF
 340
 341       ifldid      = cpl_get_fldid( 'SURF_NET_NON-SOLAR' )
 342       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 343       IF ( COUNT(lltosend) > 0 ) THEN
 344          cplsnd(ips:ipe,jps:jpe) = grid%GLW(ips:ipe,jps:jpe) &
 345             &                      - STBOLT * grid%EMISS(ips:ipe,jps:jpe) * grid%SST(ips:ipe,jps:jpe)**4 &
 346             &                      - grid%LH(ips:ipe,jps:jpe) - grid%HFX(ips:ipe,jps:jpe)
 347          CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
 348       END IF
 349
 350       ! test if we need to compute the module of the wind speed and stres
 351       icnt   =        COUNT( cpl_tosend( grid%id, cpl_get_fldid( 'TAUMOD' ), max_edom ) )
 352       icnt   = icnt + COUNT( cpl_tosend( grid%id, cpl_get_fldid( 'TAUX'   ), max_edom ) )
 353       icnt   = icnt + count( cpl_tosend( grid%id, cpl_get_fldid( 'TAUY'   ), max_edom ) )
 354       IF ( icnt > 0 ) THEN
 355          u_uo(ips:ipe,jps:jpe) = grid%u_phy(ips:ipe,kps,jps:jpe) - grid%uoce(ips:ipe,jps:jpe)
 356          v_vo(ips:ipe,jps:jpe) = grid%v_phy(ips:ipe,kps,jps:jpe) - grid%voce(ips:ipe,jps:jpe)
 357          wspd(ips:ipe,jps:jpe) = MAX( SQRT( u_uo(ips:ipe,jps:jpe)**2 + v_vo(ips:ipe,jps:jpe)**2 ), 1.e-7 )
 358          taut(ips:ipe,jps:jpe) = grid%rho(ips:ipe,kps,jps:jpe) * grid%ust(ips:ipe,jps:jpe)**2
 359       END IF
 360
 361       ifldid      = cpl_get_fldid( 'TAUX' )
 362       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 363       IF ( COUNT(lltosend) > 0 ) THEN
 364          cplsnd(ips:ipe,jps:jpe) = taut(ips:ipe,jps:jpe) * u_uo(ips:ipe,jps:jpe) / wspd(ips:ipe,jps:jpe)
 365          CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
 366       END IF
 367
 368       ifldid      = cpl_get_fldid( 'TAUY' )
 369       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 370       IF ( COUNT(lltosend) > 0 ) THEN
 371          cplsnd(ips:ipe,jps:jpe) = taut(ips:ipe,jps:jpe) * v_vo(ips:ipe,jps:jpe) / wspd(ips:ipe,jps:jpe)
 372          CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
 373       END IF
 374
 375       ifldid      = cpl_get_fldid( 'TAUMOD' )
 376       lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
 377       IF ( COUNT(lltosend) > 0 ) THEN
 378          CALL cpl_sndfield( grid%id, lltosend, ifldid, taut )
 379       END IF
 380
 381 #endif
 382    END SUBROUTINE cpl_snd2
 383
 384
 385    SUBROUTINE cpl_sndfield( kdomwrf, ldtosend, kfldid, pdata )
 386       !!-------------------------------------------------------------------
 387       !!             ***  SUBROUTINE cpl_rcv  ***
 388       !!
 389       !! ** Purpose :   send coupling data
 390       !!--------------------------------------------------------------------
 391       INTEGER,              INTENT(IN) :: kdomwrf   ! wrf domain index
 392       LOGICAL,DIMENSION(:), INTENT(IN) :: ldtosend
 393       INTEGER,              INTENT(IN) :: kfldid    ! field index
 394       REAL, DIMENSION(:,:), INTENT(IN) :: pdata     ! data to be sent
 395       !
 396       INTEGER :: jext          ! local loop indicees
 397       !!--------------------------------------------------------------------
 398
 399       DO jext = 1, SIZE(ldtosend)
 400          IF( ldtosend(jext) ) THEN
 401             IF ( coupler_name == 'oasis' ) CALL cpl_oasis_snd( kdomwrf, jext, kfldid, nsecrun, pdata )
 402          END IF
 403       END DO
 404
 405    END SUBROUTINE cpl_sndfield
 406
 407
 408    SUBROUTINE cpl_rcv( kdomwrf, cdsuffix,            &
 409       &                ids, ide, jds, jde, kds, kde, &
 410       &                ims, ime, jms, jme, kms, kme, &
 411       &                ips, ipe, jps, jpe, kps, kpe, &
 412       &                max_edom, pcplmask, pdatacpl, pdataobs )
 413       !!-------------------------------------------------------------------
 414       !!             ***  SUBROUTINE cpl_rcv  ***
 415       !!
 416       !! ** Purpose :   receive coupling data
 417       !!--------------------------------------------------------------------
 418       INTEGER,                                                   INTENT(IN   ) :: kdomwrf     ! wrf domain index
 419       CHARACTER(*),                                              INTENT(IN   ) :: cdsuffix    ! field name suffix
 420       INTEGER,                                                   INTENT(IN   ) :: ids,ide,jds,jde,kds,kde
 421       INTEGER,                                                   INTENT(IN   ) :: ims,ime,jms,jme,kms,kme
 422       INTEGER,                                                   INTENT(IN   ) :: ips,ipe,jps,jpe,kps,kpe
 423       INTEGER,                                                   INTENT(IN   ) :: max_edom    ! max number of external model domains
 424       REAL, DIMENSION( ims:ime, 1:max_edom, jms:jme ),           INTENT(IN   ) :: pcplmask    ! coupling mask
 425       REAL, DIMENSION( ims:ime,             jms:jme ),           INTENT(  OUT) :: pdatacpl    ! coupling data
 426       REAL, DIMENSION( ims:ime,             jms:jme ), OPTIONAL, INTENT(IN   ) :: pdataobs    ! observed data to be merged
 427       !
 428       INTEGER :: jext                                ! external domain index
 429       INTEGER :: ifldid                              ! field index
 430       REAL, DIMENSION( ips:ipe, jps:jpe ) :: zdata   ! data received from the coupler
 431       LOGICAL :: lltorcv
 432       !!--------------------------------------------------------------------
 433
 434       ifldid = cpl_get_fldid( cdsuffix )
 435
 436       lltorcv = .false.
 437       DO jext = 1, max_edom
 438          lltorcv = lltorcv .OR. cpl_toreceive( kdomwrf, jext, ifldid )
 439       END DO
 440       IF( .not.lltorcv ) return
 441
 442       IF( PRESENT(pdataobs) ) THEN
 443          pdatacpl(ips:ipe,jps:jpe) = pdataobs(ips:ipe,jps:jpe) * ( 1.0 - SUM( pcplmask(ips:ipe,1:max_edom,jps:jpe), dim = 2 ) )
 444       ELSE
 445          pdatacpl(ips:ipe,jps:jpe) = 0.0
 446       END IF
 447
 448       DO jext = 1, max_edom
 449          IF( cpl_toreceive( kdomwrf, jext, ifldid ) ) THEN
 450             IF( coupler_name == 'oasis' )   CALL cpl_oasis_rcv( kdomwrf, jext, ifldid, nsecrun, zdata )
 451             pdatacpl(ips:ipe,jps:jpe) = pdatacpl(ips:ipe,jps:jpe) + zdata(ips:ipe,jps:jpe) * pcplmask(ips:ipe,jext,jps:jpe)
 452          END IF
 453       END DO
 454
 455    END SUBROUTINE cpl_rcv
 456
 457
 458    SUBROUTINE cpl_store_input( grid, config_flags )
 459       !!-------------------------------------------------------------------
 460       !!             ***  SUBROUTINE cpl_store_input  ***
 461       !!
 462       !! ** Purpose : Store input data that will be merged later with data received from the coupler
 463       !!--------------------------------------------------------------------
 464       TYPE(domain)                , INTENT(INOUT) :: grid
 465       TYPE (grid_config_rec_type) , INTENT(IN   ) :: config_flags
 466       !
 467       INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
 468       INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor
 469       INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
 470       LOGICAL :: llmust_store
 471       INTEGER :: jext          ! local loop indicees
 472       !!--------------------------------------------------------------------
 473
 474 #if (EM_CORE == 1)
 475       CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
 476          &                          ims, ime, jms, jme, kms, kme, &
 477          &                          ips, ipe, jps, jpe, kps, kpe  )
 478
 479       ! take care of variables read in AUXINPUT4...
 480       ! AUXINPUT4 was just read if:
 481       ! 1) We asked (legally) for an AUXINPUT4 input AND this is the first time step AFTER an auxinput4_alarm was ringing
 482       ! OR
 483       ! 2) This is the first time step
 484       IF( ( config_flags%auxinput4_interval .NE. 0 .AND. config_flags%io_form_auxinput4 .NE. 0 .AND. grid%just_read_auxinput4 ) &
 485          .OR. grid%itimestep .EQ. 1 ) THEN
 486
 487          ! if we receive the SST, we need to store it in SST_INPUT
 488          llmust_store = .FALSE.
 489          DO jext = 1, grid%num_ext_model_couple_dom
 490             llmust_store = llmust_store .OR. cpl_toreceive( grid%id, jext, cpl_get_fldid( 'SST' ) )
 491          END DO
 492          IF( llmust_store )   grid%sst_input(ips:ipe,jps:jpe) = grid%sst(ips:ipe,jps:jpe)   ! store SST into SST_INPUT
 493
 494          grid%just_read_auxinput4 = .FALSE.  ! the work as been done and not me done again until we reread data from AUXINPUT4
 495
 496       END IF
 497 #endif
 498
 499    END SUBROUTINE cpl_store_input
 500
 501
 502    SUBROUTINE cpl_finalize()
 503       !!-------------------------------------------------------------------
 504       !!             ***  SUBROUTINE cpl_finalize  ***
 505       !!
 506       !! ** Purpose :   cpl_finalize MPI communications with the coupler
 507       !!--------------------------------------------------------------------
 508       IF ( coupler_name == 'oasis' ) CALL cpl_oasis_finalize()
 509
 510    END SUBROUTINE cpl_finalize
 511
 512
 513    SUBROUTINE cpl_abort( cdroutine, cdtxt )
 514       !!-------------------------------------------------------------------
 515       !!             ***  SUBROUTINE cpl_abort  ***
 516       !!
 517       !! ** Purpose :   abort coupling simulation
 518       !!--------------------------------------------------------------------
 519       CHARACTER(*), INTENT(IN) :: cdroutine   ! name of the subroutine calling cpl_oasis_abort
 520       CHARACTER(*), INTENT(IN) :: cdtxt       ! aborting text
 521       !!--------------------------------------------------------------------
 522
 523       IF ( coupler_name == 'oasis' ) CALL cpl_oasis_abort( cdroutine, cdtxt )
 524
 525    END SUBROUTINE cpl_abort
 526
 527
 528 END MODULE module_cpl