MODULE ATM_cc
USE CMP_COMM, ONLY: &
& MPI_COMM_Atmos => COMM_local, &
& Coupler_id, &
& component_master_rank_local, &
& process_rank_local, &
& component_nprocs, &
& ibuffer, &
& MPI_INTEGER,MPI_STATUS_SIZE, &
& kind_REAL,kind_alt_REAL, &
& MPI_kind_REAL,MPI_kind_alt_REAL
implicit none
integer,parameter:: ND=3
integer Ocean_spec /-1/, WM_id /-10/
integer NSF
integer NSF_WM
real dtc, & !<- Coupling period
& dta, & !<- AM time step ("physical")
& dta2dtc !<- AM time step / Coupling period
integer i_dtc2dta /100/ !<- Coupling period / AM time step
integer & !,dimension(ND)::
&ims,ime,jms,jme,its,ite,jts,jte,ids,idf,jds,jdf, NGP
integer kms,kme,kts,kte,kds,kde
integer,parameter:: kind_R=kind_alt_REAL
!c integer,parameter:: kind_tiling=kind_R
integer,parameter:: kind_sfcflux=kind_R, &
& kind_SST=kind_R, &
& kind_SLM=kind_R, &
& kind_lonlat=kind_REAL
INTEGER, PARAMETER :: kind_cur = kind_r, kind_wstate = kind_r, &
kind_windp = kind_r
integer MPI_kind_R, &
&MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
INTEGER :: MPI_kind_cur, MPI_kind_wstate, MPI_kind_windp
integer n_ts(ND) /0,0,0/, gid
integer rc /5/
real,parameter:: &
& SLM_OS_value=1., & !<-must be real open sea mask value in AM
& unrealistically_low_SST=0.01, & ! <- must be unreal low but >=0.,
! see interp. --- check!
& unrealistically_low_SV=-1.E30, &
! <- must be negative unreal low surface flux
! or other surface value to be sent
! to Coupler, see Coupler code
& unrealistically_low_SF=unrealistically_low_SV, & !<- same thing
& unrealistically_low_SVp=0.99*unrealistically_low_SV
logical initialized /.false./
logical PHYS,zeroSF,nrmSF,sendSF,getSST
TYPE SST_ARRAY
real(kind=kind_SST),dimension(:,:),pointer:: a
END TYPE SST_ARRAY
TYPE SF_ARRAY
real(kind=kind_sfcflux),dimension(:,:,:),pointer:: a
END TYPE SF_ARRAY
TYPE cur_array
REAL(KIND = kind_cur), dimension(:,:), pointer :: a
END TYPE cur_array
TYPE wstate_array
REAL(KIND = kind_wstate), dimension(:,:), pointer :: a
END TYPE wstate_array
TYPE windp_array
REAL(KIND = kind_windp), dimension(:,:,:), pointer :: a
END TYPE windp_array
TYPE (SST_ARRAY), dimension(ND):: SST_cc
TYPE (SF_ARRAY), dimension(min(ND,2)):: sf
TYPE (cur_array), dimension(nd) :: ucur_cc, vcur_cc
TYPE (wstate_array), dimension(nd) :: alpha_cc, gamma_cc
TYPE (windp_array), dimension(nd) :: wwinp
character*12 sgid
!Controls:
integer nunit_announce /6/, VerbLev /3/
! To control awo couplings
integer ia2o /1/, &
& io2a /1/, &
& ia2w /1/, &
& iw2a /0/
SAVE
END MODULE ATM_cc
!C
!C***********************************************************************
!C
SUBROUTINE ATM_SET_COMM(new_atm_comm)
USE ATM_cc
integer, intent(in) :: new_atm_comm
! This routine is called when the atmospheric model wants to
! remove processors from taking part in coupling so that they
! can perform I/O or diagnostics. Any processors that will
! continue to be in MPI_COMM_Atmos must call this routine, and
! any processors that will leave MPI_COMM_Atmos must call
! ATM_LEAVE_COUPLING.
MPI_COMM_Atmos=new_atm_comm
end
!C
!C***********************************************************************
!C
SUBROUTINE ATM_LEAVE_COUPLING()
USE ATM_cc
! This routine is called when the atmospheric model wants to
! remove processors from taking part in coupling so that they
! can perform I/O or diagnostics. Any processors that will
! continue to be in MPI_COMM_Atmos must call ATM_SET_COMM, and
! any processors that will leave MPI_COMM_Atmos must call
! this routine.
! Currently, there is nothing we have to do here.
return
end
!C
!C***********************************************************************
!C
SUBROUTINE ATM_CMP_START(atm_comm)
USE ATM_cc
implicit none
integer atm_comm
! integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /0/
! <- D.S.
! Atmos_spec=1 for the case when the only field AM receives
! from Coupler is SST. Atmos_spec=0 allows receiving additional
! fields from C., originating from both OM, WM. (Atmos_spec does
! not control receiving in AM but is sent to C. thus transferring
! the control to C.)
integer ibuf(1),ierr
character*20 s
!C
!<-id of OM as a component of the coupled system
call CMP_INIT(Atmos_id,1)
!<-"flexibility level"
if (Coupler_id.ge.0) VerbLev=min(VerbLev,ibuffer(4))
write(s,'(i2)') VerbLev
call CMP_INTRO(Atmos_master_rank_local)
call ATM_ANNOUNCE('back from CMP_INTRO, VerbLev='//s,2)
initialized=.true.
call CMP_INTEGER_SEND(Atmos_spec,1)
call CMP_gnr_RECV(Ocean_spec,1,MPI_INTEGER)
write(s,'(i2)') Ocean_spec
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, OM spec is '//s,2)
call MPI_BCAST(Ocean_spec,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: Ocean_spec broadcast',2)
call CMP_gnr_RECV(WM_id,1,MPI_INTEGER)
write(s,'(i4)') WM_id
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, WM id is '//s,2)
call MPI_BCAST(WM_id,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: WM_id broadcast',2)
if (WM_id.gt.0) then
NSF_WM=4
else
NSF_WM=0
end if
if (Ocean_spec.eq.1) then
NSF=4
else if (Ocean_spec.eq.2) then
NSF=8
else if (Ocean_spec.eq.0) then
NSF=1
else if (Coupler_id.ge.0) then
call GLOB_ABORT(Ocean_spec-1, &
& 'ATM_CMP_START received wrong Ocean_spec value, aborted',rc)
else
Ocean_spec=1
NSF=4
call ATM_ANNOUNCE('AM is standalone: Ocean_spec=1, NSF=4'// &
& ' assigned (as if for POM coupling)',2)
end if
call CMP_gnr_RECV(ia2o,1,MPI_INTEGER)
write(s,'(i4)') ia2o
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, ia2o is '//s,2)
call MPI_BCAST(ia2o,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: ia2o broadcast',2)
call CMP_gnr_RECV(io2a,1,MPI_INTEGER)
write(s,'(i4)') io2a
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, io2a is '//s,2)
call MPI_BCAST(io2a,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: io2a broadcast',2)
call CMP_gnr_RECV(ia2w,1,MPI_INTEGER)
write(s,'(i4)') ia2w
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, ia2w is '//s,2)
call MPI_BCAST(ia2w,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: ia2w broadcast',2)
call CMP_gnr_RECV(iw2a,1,MPI_INTEGER)
write(s,'(i4)') iw2a
call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, iw2a is '//s,2)
call MPI_BCAST(iw2a,1,MPI_INTEGER, &
&component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_CMP_START: iw2a broadcast',2)
if (kind_R.eq.kind_REAL) then
MPI_kind_R=MPI_kind_REAL
else
MPI_kind_R=MPI_kind_alt_REAL
end if
if (kind_sfcflux.eq.kind_REAL) then
MPI_kind_sfcflux=MPI_kind_REAL
else
MPI_kind_sfcflux=MPI_kind_alt_REAL
end if
if (kind_SST.eq.kind_REAL) then
MPI_kind_SST=MPI_kind_REAL
else
MPI_kind_SST=MPI_kind_alt_REAL
end if
if (kind_SLM.eq.kind_REAL) then
MPI_kind_SLM=MPI_kind_REAL
else
MPI_kind_SLM=MPI_kind_alt_REAL
end if
if (kind_lonlat.eq.kind_REAL) then
MPI_kind_lonlat=MPI_kind_REAL
else
MPI_kind_lonlat=MPI_kind_alt_REAL
end if
IF (kind_cur == kind_real) THEN
MPI_kind_cur = MPI_kind_real
ELSE
MPI_kind_cur = MPI_kind_alt_real
END IF
IF (kind_wstate == kind_real) THEN
MPI_kind_wstate = MPI_kind_real
ELSE
MPI_kind_wstate = MPI_kind_alt_real
END IF
IF (kind_windp == kind_real) THEN
MPI_kind_windp = MPI_kind_real
ELSE
MPI_kind_windp = MPI_kind_alt_real
END IF
atm_comm=MPI_COMM_Atmos
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_INIT_CHECK(s)
USE ATM_cc, ONLY: initialized,rc
implicit none
character*(*) s
if (.not. initialized) call GLOB_ABORT(1,s,rc)
return
END
!C
!C***********************************************************************
!C
subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
&ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_,ims_,ime_,jms_,jme_, &
!<-"domain" !<-"tile" !<-"memory" (tile+halo)
&kds_,kde_,kts_,kte_,kms_,kme_,&
&HLON,HLAT,VLON,VLAT, &
&SLM, &
&i_parent_start,j_parent_start,&
&guessdtc,dtc_)
USE ATM_cc
implicit none
real, intent(in) :: guessdtc
real, intent(out) :: dtc_
integer NTSD,NPHS,gid_
real dta_
integer ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_, &
&ims_,ime_,jms_,jme_,kds_,kde_,kts_,kte_,kms_,kme_
real(kind=kind_lonlat),dimension(ims_:ime_,jms_:jme_):: &
&HLON,HLAT,VLON,VLAT
real(kind=kind_SLM),dimension(ims_:ime_,jms_:jme_):: SLM
integer i_parent_start,j_parent_start
integer KDT,buf(2) /0,0/
character*24 s
character*80 s1
character*255 message
SAVE
!C
gid=gid_
call GLOB_ABORT((gid-1)*(gid-2)*(gid-3), &
&'Abort: in ATM_TSTEP_INIT gid is neither 1 nor 2 nor 3',rc)
KDT=NTSD/NPHS+1
PHYS=MOD(NTSD,NPHS).eq.0 ! .and. gid.eq.1 <-removed to bring MG in
dta=dta_
write(s1,'("gid=",i1," NTSD=",i5," NPHS=",i3," KDT=",i5,'// &
&'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS
call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3)
!c IF (n_ts.eq.-1 .and. PHYS) THEN
!c PHYS=.false.
!c n_ts=0 ! init. value must be -1 . But if PHYS does not need
!c ! this correction, init. value must be 0 (whereas this
!c ! IF statement may stay)
!c END IF
if (.not.PHYS) then
zeroSF=.false.
nrmSF=.false.
sendSF=.false.
RETURN
end if
n_ts(gid)=n_ts(gid)+1 ! init. value must be 0 ***0***
write(s,'(2i8)') KDT,n_ts(gid)
write(sgid,'(" grid id = ",i1)') gid
call ATM_ANNOUNCE('ATM_TSTEP_INIT working:'// &
&sgid//'; KDT, n_ts: '//s,3)
call GLOB_ABORT(KDT-n_ts(gid), &
&'Abort: in ATM_TSTEP_INIT KDT, n_ts(gid) differ '//s,rc)
call ATM_RECVdtc(guessdtc)
dtc_=dtc
zeroSF=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
nrmSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
sendSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
!<-check, this depends
! on where ATM_SENDFLUXES is called.
! MOD(n_ts,i_dtc2dta).eq.0 should
! be good for calling it after
! ATM_DOFLUXES at the same t.s.
ids=ids_
idf=idf_
jds=jds_
jdf=jdf_
its=its_
ite=ite_
jts=jts_
jte=jte_
ims=ims_
ime=ime_
jms=jms_
jme=jme_
kds=kds_
kde=kde_
kts=kts_
kms=kms_
kme=kme_
kte=kte_
NGP=(idf-ids+1)*(jdf-jds+1)
IF (n_ts(gid).eq.1) THEN
call ATM_ANNOUNCE('ATM_TSTEP_INIT to allocate sf, SST_cc',3)
IF (gid.le.2) THEN !** innermost grid not active in coupling **
allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
ALLOCATE(wwinp(gid)%a(ims:ime,jms:jme,NSF_WM))
END IF !** innermost grid not active in coupling **
allocate(SST_cc(gid)%a(ims:ime,jms:jme))
ALLOCATE(ucur_cc(gid)%a(ims:ime,jms:jme), vcur_cc(gid)%a(ims:ime,jms:jme))
ALLOCATE(alpha_cc(gid)%a(ims:ime,jms:jme), gamma_cc(gid)%a(ims:ime,jms:jme))
END IF
if (gid.eq.2) then
write(s,'(2i8)') i_parent_start,j_parent_start
if (zeroSF) then
buf(1)=i_parent_start
buf(2)=j_parent_start
call CMP_INTEGER_SEND(buf,2)
call ATM_ANNOUNCE( &
& 'ATM_TSTEP_INIT: i_parent_start, j_parent_start sent '//s,3)
else
call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- &
& buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// &
& s,rc)
end if
end if
IF (gid.le.2) THEN !** innermost grid not active in coupling **
CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
CALL ATM_SENDSLM(SLM)
END IF !** innermost grid not active in coupling **
if (VerbLev.ge.2) then
write(message,*) 'AM: ATM_TSTEP_INIT: returning ',gid, &
&n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
call wrf_debug(2,message)
endif
RETURN
end
!C
!C***********************************************************************
!C
SUBROUTINE ATM_RECVdtc(guessdtc)
USE ATM_cc
implicit none
real,intent(in) :: guessdtc
real(kind=kind_R) buf(1),dtc2dta
integer ierr,i
logical first/.true./
character*20 s
SAVE
!C
write(s,'(1pe20.12)') dta
call ATM_ANNOUNCE('ATM_RECVdtc: AM time step dta='//s,3)
IF (first) THEN
call ATM_ANNOUNCE( &
& 'ATM_RECVdtc: to receive C time step; AM time step dta='//s,2)
call CMP_gnr_RECV(buf,1,MPI_kind_R)
call MPI_BCAST(buf,1,MPI_kind_R, &
& component_master_rank_local,MPI_COMM_Atmos,ierr)
call ATM_ANNOUNCE('ATM_RECVdtc: C time step broadcast',2)
dtc=buf(1)
if (Coupler_id.lt.0) then
dtc=guessdtc
write(s,'(1pe20.12)') dtc
call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
& trim(s)//' : standalone mode',2)
else
write(s,'(1pe20.12)') buf
call ATM_ANNOUNCE( &
& 'ATM_RECVdtc: C time step dtc='//s//' received',2)
end if
END IF
dtc2dta=dtc/dta
i_dtc2dta=nint(dtc2dta)
if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
&'AM: ABORTED: dtc is not a multiple of dta',1)
i=3
if (n_ts(gid).eq.1) i=2
if (i_dtc2dta.eq.0) then
i_dtc2dta=4
call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
& ' This should only occur in standalone mode and ONLY IF dtc '// &
& 'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ** ATTENTION **',i)
else
write(s,'(i2)') i_dtc2dta
call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
end if
dta2dtc=1./i_dtc2dta
first=.false.
RETURN
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
USE ATM_cc
implicit none
real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
&HLON,HLAT,VLON,VLAT
real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
&ALONt,ALATt,ALONv,ALATv
integer buf(2)
!C
!c IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
IF (gid.gt.2) RETURN ! innermost grid's dim. / coor. are not sent
!temporarily excluded if (Coupler_id.lt.0) return ! <- standalone mode
buf(1)=idf-ids+1
buf(2)=jdf-jds+1
call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
call CMP_INTEGER_SEND(buf,2)
call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
!c IF (gid.eq.1) THEN ! only "parent grid" coordinates are sent
if (kind_lonlat.eq.4) then
call ASSEMBLE(ALONt,HLON,kind_lonlat)
call ASSEMBLE(ALATt,HLAT,kind_lonlat)
call ASSEMBLE(ALONv,VLON,kind_lonlat)
call ASSEMBLE(ALATv,VLAT,kind_lonlat)
else if (kind_lonlat.eq.8) then
call ASSEMBLE_R8(ALONt,HLON,kind_lonlat)
call ASSEMBLE_R8(ALATt,HLAT,kind_lonlat)
call ASSEMBLE_R8(ALONv,VLON,kind_lonlat)
call ASSEMBLE_R8(ALATv,VLAT,kind_lonlat)
else
call GLOB_ABORT(1,'wrong value of kind_lonlat in ATM_SENDGRIDS',1)
end if
call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
call ATM_ANNOUNCE('the 4 grid arrays sent',1)
!c END IF
call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_SENDSLM(SLM)
USE ATM_cc
implicit none
real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
integer buf(2)
!C
!c IF (gid.ne.1) RETURN ! only "parent grid" mask is sent
IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
IF (gid.gt.2) RETURN ! innermost grid's mask is not sent
!temporarily excluded if (Coupler_id.lt.0) return ! <- standalone mode
call ASSEMBLE(SLM_g,SLM,kind_SLM)
call ATM_ANNOUNCE('(BP) to send SLM',2)
call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
! Coupler requires as many copies of mask as there are grids
! [and mask array is the same for H- (=t-) and V- grids]
call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_GETSST(SST,SLM)
USE ATM_cc
implicit none
real(kind=kind_SST) SST(ims:ime,jms:jme)
real(kind=kind_SLM) SLM(ims:ime,jms:jme)
integer i,j
real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
!C
IF ( io2a .LT. 1 ) RETURN
IF (.not.PHYS) RETURN
IF (gid.gt.2) RETURN ! nothing is done to get innermost grid's
! SST ** IN THIS PRELIMINARY VERSION **
call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
if (getSST.neqv.zeroSF) then
call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
& ' up the design for exchanges with C',rc)
end if
if (getSST) then
if (n_ts(gid).eq.1 .and. gid.eq.1) then
call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
call ASSEMBLE(SST_g,SST,kind_SST)
call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
end if
call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
end if
if (Coupler_id.lt.0) return ! <- standalone mode
do j=jts,jte
do i=its,ite
if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then
! i.e. if it is OS (open sea) AMGP
!
if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST) &
! i.e. if there is a valid
! result of interpolation from
! OMG for this AMGP
& SST(i,j)=SST_cc(gid)%a(i,j)
end if
end do
end do
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
!c &USTAR,U10,V10,PINT,PREC)
&TX,TY,PINT,PREC)
USE ATM_cc
implicit none
real(kind=kind_sfcflux),dimension(ims:ime,jms:jme,kms:kme):: PINT
real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
&TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PREC
!c &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
! Act. arg. for PINT is a 3d array - so this only is OK if
! Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
real dtainv
!C
IF ( ia2o .LT. 1 .and. ia2w .LT. 1 ) RETURN
IF (.not.PHYS) RETURN
IF (gid.gt.2) RETURN
! Debug insertion:->
!c if (PREC(ims+3,jms+3).ne.0 .or. PREC(ims+5,jms+5).ne.0) then
!c print*,'ATM_DOFLUXES,gid,n_ts(gid),PREC(3,3),PREC(5,5): ',
!c & gid,n_ts(gid),PREC(ims+3,jms+3),PREC(ims+5,jms+5)
!c end if
! <-:Debug insertion
call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
dtainv=1./dta
if (zeroSF) sf(gid)%a=0.
SWR(its:ite,jts:jte)=-RSWIN(its:ite,jts:jte)+RSWOUT(its:ite,jts:jte) ! Check sign! here SWR is meant to be
! positive upward
!c sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX
!c sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY
!c ! <- signs for stress components are changed
!c ! so it is -stress
!c R=SWR+RADOT-RLWIN ! Check sign! here R (net radiation)
! is meant to be positive upward
!oooooooooooooooooooooooooooooo
IF (Ocean_spec.eq.1) THEN
!oooooooooooooooooooooooooooooo
sf(gid)%a(its:ite,jts:jte,NSF-3)=sf(gid)%a(its:ite,jts:jte,NSF-3)-TWBS(its:ite,jts:jte)-QWBS(its:ite,jts:jte)+RADOT(its:ite,jts:jte)-RLWIN(its:ite,jts:jte)
! -TWBS (-QWBS) is supposed to
! be sensible (latent) heat flux,
! positive upward
sf(gid)%a(its:ite,jts:jte,NSF-2)=sf(gid)%a(its:ite,jts:jte,NSF-2)+SWR(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)-TX(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)-TY(its:ite,jts:jte)
! <- signs for stress components are changed
!ooooooooooooooooooooooooooooooooooo
ELSE IF (Ocean_spec.eq.2) THEN
!ooooooooooooooooooooooooooooooooooo
sf(gid)%a(its:ite,jts:jte,NSF-7)=sf(gid)%a(its:ite,jts:jte,NSF-7)+PREC(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-6)=sf(gid)%a(its:ite,jts:jte,NSF-6)-TWBS(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-5)=sf(gid)%a(its:ite,jts:jte,NSF-5)-QWBS(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-4)=sf(gid)%a(its:ite,jts:jte,NSF-4)+PINT(its:ite,jts:jte,1)-101300.
sf(gid)%a(its:ite,jts:jte,NSF-3)=sf(gid)%a(its:ite,jts:jte,NSF-3)-SWR(its:ite,jts:jte)-RADOT(its:ite,jts:jte)+RLWIN(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-2)=sf(gid)%a(its:ite,jts:jte,NSF-2)-SWR(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)+TX(its:ite,jts:jte)
sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)+TY(its:ite,jts:jte)
! <- signs for stress components are NOT changed
if (nrmSF) then
sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)*dtainv
! so this will be m/s; check what OM wants
end if
!ooooooooooo
END IF
!ooooooooooo
if (nrmSF) then
sf(gid)%a=sf(gid)%a*dta2dtc
end if
call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_SENDFLUXES
USE ATM_cc
implicit none
real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
integer n
!C
IF ( ia2o .LT. 1 .and. ia2w .LT. 1 ) RETURN
if (.not.PHYS) RETURN
IF (gid.gt.2) RETURN
if (.not.sendSF) then
call ATM_ANNOUNCE( &
& 'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
& sgid,3)
RETURN
end if
call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
do n=1,NSF
call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
end do
call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
return
END
!C
!C***********************************************************************
!C
SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
implicit none
character*(*) s
integer DbgLev
integer ierr
!C
if (DbgLev.le.VerbLev) then
if (s(1:5).eq.'(BP) ') then
call MPI_BARRIER(MPI_COMM_Atmos,ierr)
end if
CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
end if
return
END
SUBROUTINE atm_getcur(ucur,vcur)
! Bringing ocean currents ..
! Biju Thomas, GSO/URI on 4/8/2015
!
USE atm_cc
IMPLICIT NONE
REAL(KIND = kind_cur), DIMENSION(ims:ime,jms:jme) :: ucur, vcur
REAL(KIND = kind_cur), DIMENSION(ids:idf,jds:jdf) :: ucur_g, vcur_g
REAL, PARAMETER :: cur_ll = 0._kind_cur, cur_ul = 5._kind_cur, &
cur_k = 0._kind_cur
INTEGER :: i, j
LOGICAL :: getcur
IF ( io2a .LT. 2 ) RETURN
IF (.NOT. phys .OR. gid > 2) RETURN
IF (ocean_spec /= 1) CALL atm_announce('Warn: ocean currents needed',3)
CALL atm_announce('atm_getcur entered (phys = .true.)',3)
getcur = ((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta == n_ts(gid)-1
IF (getcur .NEQV. zerosf) THEN
CALL glob_abort(1, 'Warn: getcur does not match zerosf', rc)
END IF
IF (getcur) THEN
CALL atm_announce('atm_getcur: to receive CUR',3)
CALL cmp_gnr_recv(ucur_g, ngp, mpi_kind_cur)
CALL cmp_gnr_recv(vcur_g, ngp, mpi_kind_cur)
CALL disassemble(ucur_g, ucur_cc(gid)%a, kind_cur)
CALL disassemble(vcur_g, vcur_cc(gid)%a, kind_cur)
CALL atm_announce('atm_getcur: CUR received',3)
END IF
IF ( coupler_id .LT. 0 ) RETURN
DO j = jts,jte
DO i = its,ite
IF ( ABS(ucur_cc(gid)%a(i,j)) .GE. cur_ll .AND. &
ABS(ucur_cc(gid)%a(i,j)) .LE. cur_ul ) THEN
ucur(i,j) = ucur_cc(gid)%a(i,j)
ELSE
ucur(i,j) = cur_k
ENDIF
IF ( ABS(vcur_cc(gid)%a(i,j)) .GE. cur_ll .AND. &
ABS(vcur_cc(gid)%a(i,j)) .LE. cur_ul ) THEN
vcur(i,j) = vcur_cc(gid)%a(i,j)
ELSE
vcur(i,j) = cur_k
ENDIF
ENDDO
ENDDO
END SUBROUTINE atm_getcur
SUBROUTINE atm_getwstate(alpha,gamma)
! Bringing Wave state (Charnok coeff & misalignment Angle)
! Biju Thomas, GSO/URI on 4/8/2015
!
USE atm_cc
IMPLICIT NONE
REAL(KIND = kind_wstate), DIMENSION(ims:ime,jms:jme) :: alpha, gamma
REAL(KIND = kind_wstate), DIMENSION(ids:idf,jds:jdf) :: alpha_g, &
gamma_g
REAL, PARAMETER :: deg2rad=3.1415926_kind_wstate/180_kind_wstate
REAL, PARAMETER :: alpha_ll = 0.0_kind_wstate, &
alpha_ul = 0.2_kind_wstate, &
alpha_k = 0.0185_kind_wstate, &
gamma_ll = -20.0_kind_wstate*deg2rad, &
gamma_ul = 20.0_kind_wstate*deg2rad, &
gamma_k = 0.0_kind_wstate
INTEGER :: i, j
LOGICAL :: getwstate
IF ( iw2a .LT. 1 ) RETURN
IF (wm_id <= 0) RETURN
IF (.NOT. phys .OR. gid > 2) RETURN
CALL atm_announce('atm_getstate entered (phys = .true.)',3)
getwstate = ((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta == n_ts(gid)-1
IF (getwstate .NEQV. zerosf) THEN
CALL glob_abort(1, 'Warn: getwstate does not match zerosf', rc)
END IF
IF (getwstate) THEN
CALL atm_announce('atm_getwsate: to receive WSTATE',3)
CALL cmp_gnr_recv(alpha_g, ngp, mpi_kind_wstate)
CALL cmp_gnr_recv(gamma_g, ngp, mpi_kind_wstate)
CALL disassemble(alpha_g, alpha_cc(gid)%a, kind_wstate)
CALL disassemble(gamma_g, gamma_cc(gid)%a, kind_wstate)
CALL atm_announce('atm_getwstate: WSTATE received',3)
END IF
IF ( coupler_id .LT. 0 ) RETURN
DO j = jts,jte
DO i = its,ite
! IF ( alpha_cc(gid)%a(i,j) .GT. alpha_ll .AND. &
! alpha_cc(gid)%a(i,j) .LT. alpha_ul ) THEN
! alpha(i,j) = alpha_cc(gid)%a(i,j)
! ELSE
! alpha(i,j) = alpha_k
! ENDIF
alpha(i,j) = alpha_cc(gid)%a(i,j)
IF ( gamma_cc(gid)%a(i,j) .GT. gamma_ll .AND. &
gamma_cc(gid)%a(i,j) .LT. gamma_ul ) THEN
gamma(i,j) = gamma_cc(gid)%a(i,j)
ELSE
gamma(i,j) = gamma_k
ENDIF
ENDDO
ENDDO
END SUBROUTINE atm_getwstate
SUBROUTINE atm_prepwindp(ulowl, vlowl, richn, zlowl)
! Preparing Wind and adjusting variables (Height of lowest model level
! Richarson number)
! Biju Thomas, GSO/URI on 4/8/2015
!
USE atm_cc
IMPLICIT NONE
REAL(KIND = kind_windp), DIMENSION(ims:ime,jms:jme) :: ulowl, vlowl, &
richn, zlowl
IF ( ia2w .LT. 1 ) RETURN
IF (wm_id <= 0) RETURN
IF (.NOT. phys .OR. gid > 2) RETURN
CALL atm_announce('atm_atm_prepwindp: entered',3)
IF (zerosf) wwinp(gid)%a = 0.0
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-1) = & ! D.S.
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-1) + &
ulowl(its:ite,jts:jte)
wwinp(gid)%a(its:ite,jts:jte,NSF_WM) = & ! D.S.
wwinp(gid)%a(its:ite,jts:jte,NSF_WM) + &
vlowl(its:ite,jts:jte)
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-3) = & ! D.S.
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-3) + &
richn(its:ite,jts:jte)
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-2) = & ! D.S.
wwinp(gid)%a(its:ite,jts:jte,NSF_WM-2) + &
zlowl(its:ite,jts:jte)
IF (nrmsf) THEN
wwinp(gid)%a = wwinp(gid)%a*dta2dtc
END IF
CALL atm_announce('atm_atm_prepwindp: returned',3)
END SUBROUTINE atm_prepwindp
SUBROUTINE atm_sendwindp
! Sending wind and it adjustment fields (U1, V1, Charnok coeff & misalignment Angle)
! Biju Thomas, GSO/URI on 4/8/2015
!
USE atm_cc
IMPLICIT NONE
INTEGER :: n
REAL(KIND = kind_windp), DIMENSION(ids:idf,jds:jdf) :: field
IF ( ia2w .LT. 1 ) RETURN
IF (wm_id <= 0) RETURN
IF (.NOT. phys .OR. gid > 2) RETURN
IF (.NOT. sendsf) THEN
CALL atm_announce('atm_sendwindp entered with PHYS but not sendSF: returning'// &
sgid,3)
RETURN
END IF
CALL atm_announce('atm_prepwindp: entered'//sgid,3)
DO n = 1, NSF_WM
CALL assemble(field, wwinp(gid)%a(:,:,n), kind_windp)
CALL cmp_gnr_send(field, ngp, mpi_kind_windp)
END DO
CALL atm_announce('atm_prepwindp: reterned'//sgid,3)
END SUBROUTINE atm_sendwindp