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