wrfv2_fire/external/atm_pom/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,'(i2)') 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           if (gid.eq.1) then
 340             dtc=dta*2            ! just having in mind that with gid=1
 341           else                   ! dta value is 5 times its value with
 342             dtc=dta*10           ! gid=2 (at this moment, 270s and 54s
 343           end if                 ! respectively)
 344           write(s,'(1pe20.12)') dtc
 345           call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
 346      &    trim(s)//' : standalone mode',2)
 347         else
 348           write(s,'(1pe20.12)') buf
 349           call ATM_ANNOUNCE( &
 350      &    'ATM_RECVdtc: C time step dtc='//s//' received',2)
 351         end if
 352       END IF
 353
 354       dtc2dta=dtc/dta
 355       i_dtc2dta=nint(dtc2dta)
 356       if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
 357      &'AM: ABORTED: dtc is not a multiple of dta',1)
 358
 359       i=3
 360       if (n_ts(gid).eq.1) i=2
 361       if (i_dtc2dta.eq.0) then
 362         i_dtc2dta=4
 363         call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
 364      &  ' This should only occur in standalone mode and ONLY IF dtc '// &
 365      &  'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ** ATTENTION **',i)
 366       else
 367         write(s,'(i2)') i_dtc2dta
 368         call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
 369       end if
 370
 371       dta2dtc=1./i_dtc2dta
 372
 373       first=.false.
 374
 375       RETURN
 376       END
 377 !C
 378 !C***********************************************************************
 379 !C
 380       SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
 381
 382       USE ATM_cc
 383
 384       implicit none
 385
 386       real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
 387      &HLON,HLAT,VLON,VLAT
 388
 389       real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
 390      &ALONt,ALATt,ALONv,ALATv
 391
 392       integer buf(2)
 393 !C
 394
 395 !c     IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
 396
 397       IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
 398
 399 !temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
 400
 401       buf(1)=idf-ids+1
 402       buf(2)=jdf-jds+1
 403       call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
 404       call CMP_INTEGER_SEND(buf,2)
 405       call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
 406
 407 !c     IF (gid.eq.1) THEN    !  only "parent grid" coordinates are sent
 408
 409         call ASSEMBLE(ALONt,HLON,kind_lonlat)
 410         call ASSEMBLE(ALATt,HLAT,kind_lonlat)
 411         call ASSEMBLE(ALONv,VLON,kind_lonlat)
 412         call ASSEMBLE(ALATv,VLAT,kind_lonlat)
 413
 414         call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
 415
 416         call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
 417         call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
 418         call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
 419         call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
 420
 421         call ATM_ANNOUNCE('the 4 grid arrays sent',1)
 422
 423 !c     END IF
 424
 425       call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
 426
 427       return
 428       END
 429 !C
 430 !C***********************************************************************
 431 !C
 432       SUBROUTINE ATM_SENDSLM(SLM)
 433
 434       USE ATM_cc
 435
 436       implicit none
 437
 438       real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
 439
 440       real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
 441       integer buf(2)
 442 !C
 443
 444 !c     IF (gid.ne.1) RETURN  !  only "parent grid" mask is sent
 445       IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
 446
 447 !temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
 448
 449       call ASSEMBLE(SLM_g,SLM,kind_SLM)
 450
 451       call ATM_ANNOUNCE('(BP) to send SLM',2)
 452
 453       call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
 454       call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
 455            ! Coupler requires as many copies of mask as there are grids
 456
 457       call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
 458
 459       return
 460       END
 461 !C
 462 !C***********************************************************************
 463 !C
 464       SUBROUTINE ATM_GETSST(SST,SLM)
 465
 466       USE ATM_cc
 467
 468       implicit none
 469
 470       real(kind=kind_SST) SST(ims:ime,jms:jme)
 471       real(kind=kind_SLM) SLM(ims:ime,jms:jme)
 472
 473       integer i,j
 474       real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
 475 !C
 476
 477       IF (.not.PHYS) RETURN
 478
 479       call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
 480
 481       getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
 482       if (getSST.neqv.zeroSF) then
 483         call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
 484      &  ' up the design for exchanges with C',rc)
 485       end if
 486
 487       if (getSST) then
 488         if (n_ts(gid).eq.1 .and. gid.eq.1) then
 489           call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
 490           call ASSEMBLE(SST_g,SST,kind_SST)
 491           call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
 492           call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
 493         end if
 494         call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
 495         call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
 496         call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
 497         call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
 498       end if
 499
 500       if (Coupler_id.lt.0) return    !   <- standalone mode
 501
 502       do j=jts,jte
 503       do i=its,ite
 504         if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then
 505                                   ! i.e. if it is OS (open sea) AMGP
 506                                   !
 507           if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST)  &
 508                                           ! i.e. if there is a valid
 509                                           ! result of interpolation from
 510                                           ! OMG for this AMGP
 511      &       SST(i,j)=SST_cc(gid)%a(i,j)
 512         end if
 513       end do
 514       end do
 515
 516       return
 517       END
 518 !C
 519 !C***********************************************************************
 520 !C
 521       SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
 522 !c    &USTAR,U10,V10,PINT,PREC)
 523      &TX,TY,PINT,PREC,U10,V10)
 524
 525       USE ATM_cc
 526
 527       implicit none
 528
 529       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
 530      &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC,U10,V10
 531 !c    &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
 532 !       Act. arg. for PINT is a 3d array - so this only is OK if
 533 !       Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
 534
 535       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
 536       real dtainv
 537 !C
 538
 539       IF (.not.PHYS) RETURN
 540 ! Debug insertion:->
 541 !c     if (PREC(ims+3,jms+3).ne.0 .or. PREC(ims+5,jms+5).ne.0) then
 542 !c       print*,'ATM_DOFLUXES,gid,n_ts(gid),PREC(3,3),PREC(5,5): ',
 543 !c    &  gid,n_ts(gid),PREC(ims+3,jms+3),PREC(ims+5,jms+5)
 544 !c     end if
 545 ! <-:Debug insertion
 546
 547       call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
 548
 549       dtainv=1./dta
 550
 551       if (zeroSF) sf(gid)%a=0.
 552
 553       SWR=-RSWIN+RSWOUT          ! Check sign! here SWR is meant to be
 554                                  ! positive upward
 555 !c     sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX
 556 !c     sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY
 557 !c                    ! <- signs for stress components are     changed
 558 !c                    ! so it is -stress
 559
 560 !c     R=SWR+RADOT-RLWIN          ! Check sign! here R (net radiation)
 561                                  ! is meant to be positive upward
 562
 563 !oooooooooooooooooooooooooooooo
 564       IF (Ocean_spec.eq.1) THEN
 565 !oooooooooooooooooooooooooooooo
 566         sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN
 567                                        ! -TWBS (-QWBS) is supposed to
 568                                        ! be sensible (latent) heat flux,
 569                                        ! positive upward
 570         sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR
 571         sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)-TX
 572         sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)-TY
 573                      ! <- signs for stress components are changed
 574 !ooooooooooooooooooooooooooooooooooo
 575       ELSE IF (Ocean_spec.eq.2) THEN
 576 !ooooooooooooooooooooooooooooooooooo
 577         sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)+PREC
 578         sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)-TWBS
 579         sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-QWBS
 580         sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)+PINT-101300.
 581         sf(gid)%a(:,:,5)=sf(gid)%a(:,:,5)-SWR-RADOT+RLWIN
 582         sf(gid)%a(:,:,6)=sf(gid)%a(:,:,6)-SWR
 583
 584         sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)+TX
 585         sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)+TY
 586                      ! <- signs for stress components are NOT changed
 587         if (nrmSF) then
 588           sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)*dtainv
 589                         ! so this will be m/s; check what OM wants
 590         end if
 591 !ooooooooooo
 592       END IF
 593 !ooooooooooo
 594
 595
 596 !wwwwwwwwwwwwwwwwwwwwwwwww
 597       IF (WM_id.gt.0) THEN
 598 !wwwwwwwwwwwwwwwwwwwwwwwww
 599         sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)+U10
 600         sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)+V10
 601 !wwwwwwwwwww
 602       END IF
 603 !wwwwwwwwwww
 604
 605       if (nrmSF) then
 606         sf(gid)%a=sf(gid)%a*dta2dtc
 607       end if
 608
 609       call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
 610
 611       return
 612       END
 613 !C
 614 !C***********************************************************************
 615 !C
 616       SUBROUTINE ATM_SENDFLUXES
 617
 618       USE ATM_cc
 619
 620       implicit none
 621
 622       real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
 623       integer n
 624 !C
 625
 626       if (.not.PHYS) RETURN
 627
 628       if (.not.sendSF) then
 629         call ATM_ANNOUNCE( &
 630      &  'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
 631      &  sgid,3)
 632         RETURN
 633       end if
 634
 635       call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
 636
 637       do n=1,NSF
 638         call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
 639         call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
 640       end do
 641
 642       call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
 643
 644       return
 645       END
 646 !C
 647 !C***********************************************************************
 648 !C
 649       SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
 650
 651       USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
 652
 653       implicit none
 654
 655       character*(*) s
 656       integer DbgLev
 657
 658       integer ierr
 659 !C
 660       if (DbgLev.le.VerbLev) then
 661         if (s(1:5).eq.'(BP) ') then
 662           call MPI_BARRIER(MPI_COMM_Atmos,ierr)
 663         end if
 664         CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
 665       end if
 666
 667       return
 668       END