wrfv2_fire/external/atm_ocn/atm_comm.F

   1       MODULE ATM_cc
   2
   3       USE CMP_COMM, ONLY: &
   4
   5      &   MPI_COMM_Atmos => COMM_local, &
   6
   7      &   Coupler_id, &
   8      &   component_master_rank_local, &
   9      &   process_rank_local, &
  10      &   component_nprocs, &
  11      &   ibuffer, &
  12
  13      &   MPI_INTEGER,MPI_STATUS_SIZE, &
  14      &   kind_REAL,kind_alt_REAL, &
  15      &   MPI_kind_REAL,MPI_kind_alt_REAL
  16
  17       implicit none
  18
  19       integer,parameter:: ND=2
  20       integer Ocean_spec /-1/, WM_id /-10/
  21       integer NSF
  22       integer NSF_WM
  23       real dtc,           &       !<- Coupling period
  24      &     dta,           &     !<- AM time step ("physical")
  25      &     dta2dtc              !<- AM time step / Coupling period
  26       integer i_dtc2dta /100/   !<- Coupling period / AM time step
  27       integer & !,dimension(ND)::
  28      &ims,ime,jms,jme,its,ite,jts,jte,ids,idf,jds,jdf,  NGP
  29       integer kms,kme,kts,kte,kds,kde
  30       integer,parameter:: kind_R=kind_alt_REAL
  31 !c     integer,parameter:: kind_tiling=kind_R
  32       integer,parameter:: kind_sfcflux=kind_R, &
  33      &                    kind_SST=kind_R, &
  34      &                    kind_SLM=kind_R, &
  35      &                    kind_lonlat=kind_R
  36       integer MPI_kind_R, &
  37      &MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
  38       integer n_ts(ND) /0,0/, gid
  39       integer rc /5/
  40       real,parameter:: &
  41      &   SLM_OS_value=1.,  &!<-must be real open sea mask value in AM
  42      &   unrealistically_low_SST=0.01, & ! <- must be unreal low but >=0.,
  43                                        ! see interp. --- check!
  44      &   unrealistically_low_SV=-1.E30, &
  45                      ! <- must be negative unreal low surface flux
  46                      ! or other surface value to be sent
  47                      ! to Coupler, see Coupler code
  48      &   unrealistically_low_SF=unrealistically_low_SV, & !<- same thing
  49      &   unrealistically_low_SVp=0.99*unrealistically_low_SV
  50
  51       logical initialized /.false./
  52       logical PHYS,zeroSF,nrmSF,sendSF,getSST
  53
  54       TYPE SST_ARRAY
  55         real(kind=kind_SST),dimension(:,:),pointer:: a
  56       END TYPE SST_ARRAY
  57       TYPE SF_ARRAY
  58         real(kind=kind_sfcflux),dimension(:,:,:),pointer:: a
  59       END TYPE SF_ARRAY
  60
  61       TYPE (SST_ARRAY), dimension(ND):: SST_cc
  62       TYPE (SF_ARRAY), dimension(ND):: sf
  63
  64       character*12 sgid
  65
  66 !Controls:
  67       integer nunit_announce /6/, VerbLev /3/
  68
  69       SAVE
  70
  71       END MODULE ATM_cc
  72 !C
  73 !C***********************************************************************
  74 !C
  75       SUBROUTINE ATM_CMP_START(atm_comm)
  76
  77       USE ATM_cc
  78
  79       implicit none
  80
  81       integer atm_comm
  82
  83       integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
  84       integer ibuf(1),ierr
  85       character*20 s
  86 !C
  87
  88                       !<-id of OM as a component of the coupled system
  89       call CMP_INIT(Atmos_id,1)
  90                              !<-"flexibility level"
  91       if (Coupler_id.ge.0) VerbLev=min(VerbLev,ibuffer(4))
  92       write(s,'(i2)') VerbLev
  93
  94       call CMP_INTRO(Atmos_master_rank_local)
  95       call ATM_ANNOUNCE('back from CMP_INTRO, VerbLev='//s,2)
  96
  97       initialized=.true.
  98
  99       call CMP_INTEGER_SEND(Atmos_spec,1)
 100
 101       call CMP_gnr_RECV(Ocean_spec,1,MPI_INTEGER)
 102       write(s,'(i2)') Ocean_spec
 103       call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, OM spec is '//s,2)
 104       call MPI_BCAST(Ocean_spec,1,MPI_INTEGER, &
 105      &component_master_rank_local,MPI_COMM_Atmos,ierr)
 106       call ATM_ANNOUNCE('ATM_CMP_START: Ocean_spec broadcast',2)
 107
 108       call CMP_gnr_RECV(WM_id,1,MPI_INTEGER)
 109       write(s,'(i3)') WM_id
 110       call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, WM id is '//s,2)
 111       call MPI_BCAST(WM_id,1,MPI_INTEGER, &
 112      &component_master_rank_local,MPI_COMM_Atmos,ierr)
 113       call ATM_ANNOUNCE('ATM_CMP_START: WM_id broadcast',2)
 114       if (WM_id.gt.0) then
 115         NSF_WM=2
 116       else
 117         NSF_WM=0
 118       end if
 119
 120       if (Ocean_spec.eq.1) then
 121         NSF=4+NSF_WM
 122       else if (Ocean_spec.eq.2) then
 123         NSF=8+NSF_WM
 124       else if (Ocean_spec.eq.0) then
 125         NSF=NSF_WM
 126       else if (Coupler_id.ge.0) then
 127         call GLOB_ABORT(Ocean_spec-1, &
 128      &  'ATM_CMP_START received wrong Ocean_spec value, aborted',rc)
 129       else
 130         Ocean_spec=1
 131         NSF=4
 132         call ATM_ANNOUNCE('AM is standalone: Ocean_spec=1, NSF=4'// &
 133      &  ' assigned (as if for POM coupling)',2)
 134       end if
 135
 136       if (kind_R.eq.kind_REAL) then
 137         MPI_kind_R=MPI_kind_REAL
 138       else
 139         MPI_kind_R=MPI_kind_alt_REAL
 140       end if
 141       if (kind_sfcflux.eq.kind_REAL) then
 142         MPI_kind_sfcflux=MPI_kind_REAL
 143       else
 144         MPI_kind_sfcflux=MPI_kind_alt_REAL
 145       end if
 146       if (kind_SST.eq.kind_REAL) then
 147         MPI_kind_SST=MPI_kind_REAL
 148       else
 149         MPI_kind_SST=MPI_kind_alt_REAL
 150       end if
 151       if (kind_SLM.eq.kind_REAL) then
 152         MPI_kind_SLM=MPI_kind_REAL
 153       else
 154         MPI_kind_SLM=MPI_kind_alt_REAL
 155       end if
 156       if (kind_lonlat.eq.kind_REAL) then
 157         MPI_kind_lonlat=MPI_kind_REAL
 158       else
 159         MPI_kind_lonlat=MPI_kind_alt_REAL
 160       end if
 161
 162       atm_comm=MPI_COMM_Atmos
 163
 164       return
 165       END
 166 !C
 167 !C***********************************************************************
 168 !C
 169       SUBROUTINE ATM_INIT_CHECK(s)
 170
 171       USE ATM_cc, ONLY: initialized,rc
 172
 173       implicit none
 174
 175       character*(*) s
 176
 177       if (.not. initialized) call GLOB_ABORT(1,s,rc)
 178
 179       return
 180       END
 181 !C
 182 !C***********************************************************************
 183 !C
 184       subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
 185      &ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_,ims_,ime_,jms_,jme_, &
 186        !<-"domain"         !<-"tile"           !<-"memory" (tile+halo)
 187      &kds_,kde_,kts_,kte_,kms_,kme_, &
 188      &HLON,HLAT,VLON,VLAT, &
 189      &SLM, &
 190      &i_parent_start,j_parent_start)
 191
 192       USE ATM_cc
 193
 194       implicit none
 195
 196       integer NTSD,NPHS,gid_
 197       real dta_
 198       integer ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_, &
 199      &ims_,ime_,jms_,jme_,kds_,kde_,kts_,kte_,kms_,kme_
 200       real(kind=kind_lonlat),dimension(ims_:ime_,jms_:jme_):: &
 201      &HLON,HLAT,VLON,VLAT
 202       real(kind=kind_SLM),dimension(ims_:ime_,jms_:jme_):: SLM
 203       integer i_parent_start,j_parent_start
 204
 205       integer KDT,buf(2) /0,0/
 206       character*24 s
 207       character*80 s1
 208
 209       SAVE
 210 !C
 211
 212       gid=gid_
 213       call GLOB_ABORT((gid-1)*(gid-2), &
 214      &'Abort: in ATM_TSTEP_INIT gid is neither 1 nor 2',rc)
 215       KDT=NTSD/NPHS+1
 216       PHYS=MOD(NTSD,NPHS).eq.0 ! .and. gid.eq.1 <-removed to bring MG in
 217       dta=dta_
 218
 219       write(s1,'("gid=",i1," NTSD=",i5," NPHS=",i3," KDT=",i5,'// &
 220      &'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS
 221       call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3)
 222
 223 !c     IF (n_ts.eq.-1 .and. PHYS) THEN
 224 !c       PHYS=.false.
 225 !c       n_ts=0   ! init. value must be -1 . But if PHYS does not need
 226 !c                ! this correction, init. value must be 0 (whereas this
 227 !c                ! IF statement may stay)
 228 !c     END IF
 229       if (.not.PHYS) then
 230         zeroSF=.false.
 231         nrmSF=.false.
 232         sendSF=.false.
 233         RETURN
 234       end if
 235
 236       n_ts(gid)=n_ts(gid)+1  ! init. value must be 0   ***0***
 237       write(s,'(2i8)') KDT,n_ts(gid)
 238       write(sgid,'(" grid id = ",i1)') gid
 239       call ATM_ANNOUNCE('ATM_TSTEP_INIT working:'// &
 240      &sgid//'; KDT, n_ts: '//s,3)
 241       call GLOB_ABORT(KDT-n_ts(gid), &
 242      &'Abort: in ATM_TSTEP_INIT KDT, n_ts(gid) differ '//s,rc)
 243
 244       call ATM_RECVdtc
 245
 246       zeroSF=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
 247       nrmSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
 248       sendSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
 249                                     !<-check, this depends
 250                                     ! on where ATM_SENDFLUXES is called.
 251                                     ! MOD(n_ts,i_dtc2dta).eq.0 should
 252                                     ! be good for calling it after
 253                                     ! ATM_DOFLUXES at the same t.s.
 254
 255       ids=ids_
 256       idf=idf_
 257       jds=jds_
 258       jdf=jdf_
 259       its=its_
 260       ite=ite_
 261       jts=jts_
 262       jte=jte_
 263       ims=ims_
 264       ime=ime_
 265       jms=jms_
 266       jme=jme_
 267
 268       kds=kds_
 269       kde=kde_
 270       kts=kts_
 271       kms=kms_
 272       kme=kme_
 273       kte=kte_
 274
 275       NGP=(idf-ids+1)*(jdf-jds+1)
 276
 277       call ATM_ANNOUNCE('ATM_TSTEP_INIT to allocate sf, SST_cc',3)
 278
 279       IF (n_ts(gid).eq.1) THEN
 280         allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
 281         allocate(SST_cc(gid)%a(ims:ime,jms:jme))
 282       END IF
 283
 284       if (gid.eq.2) then
 285         write(s,'(2i8)') i_parent_start,j_parent_start
 286         if (zeroSF) then
 287           buf(1)=i_parent_start
 288           buf(2)=j_parent_start
 289           call CMP_INTEGER_SEND(buf,2)
 290           call ATM_ANNOUNCE( &
 291      &    'ATM_TSTEP_INIT: i_parent_start, j_parent_start sent '//s,3)
 292         else
 293           call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- &
 294      &    buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// &
 295      &    s,rc)
 296         end if
 297       end if
 298
 299       CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
 300
 301       CALL ATM_SENDSLM(SLM)
 302
 303       if (VerbLev.ge.2) print*,'AM: ATM_TSTEP_INIT: returning ',gid, &
 304      &n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
 305
 306       RETURN
 307       end
 308 !C
 309 !C***********************************************************************
 310 !C
 311       SUBROUTINE ATM_RECVdtc
 312
 313       USE ATM_cc
 314
 315       implicit none
 316
 317       real(kind=kind_R) buf(1),dtc2dta
 318       integer ierr,i
 319       logical first/.true./
 320       character*20 s
 321       SAVE
 322 !C
 323
 324       write(s,'(1pe20.12)') dta
 325       call ATM_ANNOUNCE('ATM_RECVdtc: AM time step dta='//s,3)
 326
 327       IF (first) THEN
 328         call ATM_ANNOUNCE( &
 329      &  'ATM_RECVdtc: to receive C time step; AM time step dta='//s,2)
 330
 331         call CMP_gnr_RECV(buf,1,MPI_kind_R)
 332
 333         call MPI_BCAST(buf,1,MPI_kind_R, &
 334      &  component_master_rank_local,MPI_COMM_Atmos,ierr)
 335         call ATM_ANNOUNCE('ATM_RECVdtc: C time step broadcast',2)
 336         dtc=buf(1)
 337
 338         if (Coupler_id.lt.0) then
 339            ! This section sets the coupling timestep when no coupling
 340            ! is being done.  This relation must hold for the outermost domain:
 341            !    dtc * N = dta * movemin
 342            ! where N can be any integer greater than zero.
 343           if(gid<1 .or. gid>3) then
 344              write(s,'(1i8)') gid
 345              call GLOB_ABORT(1,'invalid grid id '//s//'; I only know 1,2, and 3',1)
 346           endif
 347           dtc=dta
 348           if(gid==2) dtc=dtc*3   ! domain 2 timestep = domain 1 timestep / 3
 349           if(gid==3) dtc=dtc*9   ! domain 3 timestep = domain 1 timestep / 9
 350           write(s,'(1pe20.12)') dtc
 351           call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
 352      &    trim(s)//' : standalone mode',2)
 353         else
 354           write(s,'(1pe20.12)') buf
 355           call ATM_ANNOUNCE( &
 356      &    'ATM_RECVdtc: C time step dtc='//s//' received',2)
 357         end if
 358       END IF
 359
 360       dtc2dta=dtc/dta
 361       i_dtc2dta=nint(dtc2dta)
 362       if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
 363      &'AM: ABORTED: dtc is not a multiple of dta',1)
 364
 365       i=3
 366       if (n_ts(gid).eq.1) i=2
 367       if (i_dtc2dta.eq.0) then
 368         i_dtc2dta=4
 369         call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
 370      &  ' This should only occur in standalone mode and ONLY IF dtc '// &
 371      &  'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ** ATTENTION **',i)
 372       else
 373         write(s,'(i2)') i_dtc2dta
 374         call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
 375       end if
 376
 377       dta2dtc=1./i_dtc2dta
 378
 379       first=.false.
 380
 381       RETURN
 382       END
 383 !C
 384 !C***********************************************************************
 385 !C
 386       SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
 387
 388       USE ATM_cc
 389
 390       implicit none
 391
 392       real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
 393      &HLON,HLAT,VLON,VLAT
 394
 395       real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
 396      &ALONt,ALATt,ALONv,ALATv
 397
 398       integer buf(2)
 399 !C
 400
 401 !c     IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
 402
 403       IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
 404
 405 !temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
 406
 407       buf(1)=idf-ids+1
 408       buf(2)=jdf-jds+1
 409       call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
 410       call CMP_INTEGER_SEND(buf,2)
 411       call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
 412
 413 !c     IF (gid.eq.1) THEN    !  only "parent grid" coordinates are sent
 414
 415         call ASSEMBLE(ALONt,HLON,kind_lonlat)
 416         call ASSEMBLE(ALATt,HLAT,kind_lonlat)
 417         call ASSEMBLE(ALONv,VLON,kind_lonlat)
 418         call ASSEMBLE(ALATv,VLAT,kind_lonlat)
 419
 420         call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
 421
 422         call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
 423         call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
 424         call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
 425         call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
 426
 427         call ATM_ANNOUNCE('the 4 grid arrays sent',1)
 428
 429 !c     END IF
 430
 431       call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
 432
 433       return
 434       END
 435 !C
 436 !C***********************************************************************
 437 !C
 438       SUBROUTINE ATM_SENDSLM(SLM)
 439
 440       USE ATM_cc
 441
 442       implicit none
 443
 444       real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
 445
 446       real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
 447       integer buf(2)
 448 !C
 449
 450 !c     IF (gid.ne.1) RETURN  !  only "parent grid" mask is sent
 451       IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
 452
 453 !temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
 454
 455       call ASSEMBLE(SLM_g,SLM,kind_SLM)
 456
 457       call ATM_ANNOUNCE('(BP) to send SLM',2)
 458
 459       call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
 460       call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
 461            ! Coupler requires as many copies of mask as there are grids
 462
 463       call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
 464
 465       return
 466       END
 467 !C
 468 !C***********************************************************************
 469 !C
 470       SUBROUTINE ATM_GETSST(SST,SLM)
 471
 472       USE ATM_cc
 473
 474       implicit none
 475
 476       real(kind=kind_SST) SST(ims:ime,jms:jme)
 477       real(kind=kind_SLM) SLM(ims:ime,jms:jme)
 478
 479       integer i,j
 480       real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
 481 !C
 482
 483       IF (.not.PHYS) RETURN
 484
 485       call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
 486
 487       getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
 488       if (getSST.neqv.zeroSF) then
 489         call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
 490      &  ' up the design for exchanges with C',rc)
 491       end if
 492
 493       if (getSST) then
 494         if (n_ts(gid).eq.1 .and. gid.eq.1) then
 495           call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
 496           call ASSEMBLE(SST_g,SST,kind_SST)
 497           call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
 498           call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
 499         end if
 500         call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
 501         call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
 502         call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
 503         call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
 504       end if
 505
 506       if (Coupler_id.lt.0) return    !   <- standalone mode
 507
 508       do j=jts,jte
 509       do i=its,ite
 510         if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then
 511                                   ! i.e. if it is OS (open sea) AMGP
 512                                   !
 513           if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST)  &
 514                                           ! i.e. if there is a valid
 515                                           ! result of interpolation from
 516                                           ! OMG for this AMGP
 517      &       SST(i,j)=SST_cc(gid)%a(i,j)
 518         end if
 519       end do
 520       end do
 521
 522       return
 523       END
 524 !C
 525 !C***********************************************************************
 526 !C
 527       SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
 528 !c    &USTAR,U10,V10,PINT,PREC)
 529      &TX,TY,PINT,PREC,U10,V10)
 530
 531       USE ATM_cc
 532
 533       implicit none
 534
 535       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
 536      &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC,U10,V10
 537 !c    &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
 538 !       Act. arg. for PINT is a 3d array - so this only is OK if
 539 !       Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
 540
 541       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
 542       real dtainv
 543 !C
 544
 545       IF (.not.PHYS) RETURN
 546 ! Debug insertion:->
 547 !c     if (PREC(ims+3,jms+3).ne.0 .or. PREC(ims+5,jms+5).ne.0) then
 548 !c       print*,'ATM_DOFLUXES,gid,n_ts(gid),PREC(3,3),PREC(5,5): ',
 549 !c    &  gid,n_ts(gid),PREC(ims+3,jms+3),PREC(ims+5,jms+5)
 550 !c     end if
 551 ! <-:Debug insertion
 552
 553       call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
 554
 555       dtainv=1./dta
 556
 557       if (zeroSF) sf(gid)%a=0.
 558
 559       SWR=-RSWIN+RSWOUT          ! Check sign! here SWR is meant to be
 560                                  ! positive upward
 561 !c     sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX
 562 !c     sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY
 563 !c                    ! <- signs for stress components are     changed
 564 !c                    ! so it is -stress
 565
 566 !c     R=SWR+RADOT-RLWIN          ! Check sign! here R (net radiation)
 567                                  ! is meant to be positive upward
 568
 569 !oooooooooooooooooooooooooooooo
 570       IF (Ocean_spec.eq.1) THEN
 571 !oooooooooooooooooooooooooooooo
 572         sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN
 573                                        ! -TWBS (-QWBS) is supposed to
 574                                        ! be sensible (latent) heat flux,
 575                                        ! positive upward
 576         sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR
 577         sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)-TX
 578         sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)-TY
 579                      ! <- signs for stress components are changed
 580 !ooooooooooooooooooooooooooooooooooo
 581       ELSE IF (Ocean_spec.eq.2) THEN
 582 !ooooooooooooooooooooooooooooooooooo
 583         sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)+PREC
 584         sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)-TWBS
 585         sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-QWBS
 586         sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)+PINT-101300.
 587         sf(gid)%a(:,:,5)=sf(gid)%a(:,:,5)-SWR-RADOT+RLWIN
 588         sf(gid)%a(:,:,6)=sf(gid)%a(:,:,6)-SWR
 589
 590         sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)+TX
 591         sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)+TY
 592                      ! <- signs for stress components are NOT changed
 593         if (nrmSF) then
 594           sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)*dtainv
 595                         ! so this will be m/s; check what OM wants
 596         end if
 597 !ooooooooooo
 598       END IF
 599 !ooooooooooo
 600
 601
 602 !wwwwwwwwwwwwwwwwwwwwwwwww
 603       IF (WM_id.gt.0) THEN
 604 !wwwwwwwwwwwwwwwwwwwwwwwww
 605         sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)+U10
 606         sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)+V10
 607 !wwwwwwwwwww
 608       END IF
 609 !wwwwwwwwwww
 610
 611       if (nrmSF) then
 612         sf(gid)%a=sf(gid)%a*dta2dtc
 613       end if
 614
 615       call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
 616
 617       return
 618       END
 619 !C
 620 !C***********************************************************************
 621 !C
 622       SUBROUTINE ATM_SENDFLUXES
 623
 624       USE ATM_cc
 625
 626       implicit none
 627
 628       real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
 629       integer n
 630 !C
 631
 632       if (.not.PHYS) RETURN
 633
 634       if (.not.sendSF) then
 635         call ATM_ANNOUNCE( &
 636      &  'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
 637      &  sgid,3)
 638         RETURN
 639       end if
 640
 641       call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
 642
 643       do n=1,NSF
 644         call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
 645         call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
 646       end do
 647
 648       call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
 649
 650       return
 651       END
 652 !C
 653 !C***********************************************************************
 654 !C
 655       SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
 656
 657       USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
 658
 659       implicit none
 660
 661       character*(*) s
 662       integer DbgLev
 663
 664       integer ierr
 665 !C
 666       if (DbgLev.le.VerbLev) then
 667         if (s(1:5).eq.'(BP) ') then
 668           call MPI_BARRIER(MPI_COMM_Atmos,ierr)
 669         end if
 670         CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
 671       end if
 672
 673       return
 674       END