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 !!!!! USE ATM_TILES,ONLY: ASSEMBLE,DISASSEMBLE !!!!! USE MODULE_PATCH_QUILT,ONLY: PATCH,QUILT_2 USE MPI_MORE,ONLY: GLOB_ABORT implicit none integer,parameter:: ND=3 integer,dimension(1) :: Ocean_spec = (/-1/) integer,dimension(1) :: WM_id = (/-10/) ! To control awo couplings integer,dimension(1) :: ia2o = (/1/) integer,dimension(1) :: io2a = (/1/) integer,dimension(1) :: ia2w = (/1/) integer,dimension(1) :: iw2a = (/0/) ! 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 & &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 integer,parameter:: kind_sfcflux=kind_R, & & kind_SST=kind_R, & & kind_SLM=kind_R, & & kind_lonlat=8 !CoorR8 !CoorR8 & kind_lonlat=kind_R integer MPI_kind_R, & &MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat integer, dimension(ND) :: n_ts=0 integer :: 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 (SST_ARRAY), dimension(ND) :: SST_cc TYPE (SF_ARRAY), dimension(min(ND,2)) :: sf character*12 sgid !Controls: integer nunit_announce /6/, VerbLev /3/ SAVE CONTAINS !C !C*********************************************************************** !C SUBROUTINE ATM_SET_COMM(new_atm_comm) 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 SUBROUTINE ATM_SET_COMM !C !C*********************************************************************** !C SUBROUTINE ATM_LEAVE_COUPLING() ! 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 SUBROUTINE ATM_LEAVE_COUPLING !C !C*********************************************************************** !C SUBROUTINE ATM_CMP_START(atm_comm) implicit none integer atm_comm integer Atmos_id /1/, Atmos_master_rank_local /0/ !rv integer,dimension(1) :: Atmos_spec = (/1/) integer,dimension(1) :: Atmos_spec = (/1001/) integer ibuf(1),ierr,ntasks character*20 s !C 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(1).gt.0) then NSF_WM=2 else NSF_WM=0 end if if (Ocean_spec(1).eq.1) then NSF=4+NSF_WM else if (Ocean_spec(1).eq.2) then NSF=8+NSF_WM else if (Ocean_spec(1).eq.0) then NSF=NSF_WM else if (Coupler_id.ge.0) then call GLOB_ABORT(Ocean_spec(1)-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 !rv 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) !rv 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 atm_comm=MPI_COMM_Atmos return END SUBROUTINE ATM_CMP_START !C !C*********************************************************************** !C SUBROUTINE ATM_INIT_CHECK(s) implicit none character*(*) s if (.not. initialized) call GLOB_ABORT(1,s,rc) return END SUBROUTINE ATM_INIT_CHECK !C !C*********************************************************************** !C subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, & &mype,num_pes,mpi_comm_comp, & &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_) implicit none real, intent(in) :: guessdtc real, intent(out) :: dtc_ integer, intent(in) :: mype,num_pes,mpi_comm_comp 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 dta=dta_ write(s1,'("gid=",i1," NTSD=",i6," NPHS=",i3," KDT=",i5,'// & &'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3) 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) call GLOB_ABORT(KDT-n_ts(gid), & &'Abort: in ATM_TSTEP_INIT KDT, n_ts 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)) END IF !** innermost grid not active in coupling ** allocate(SST_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 if (i_parent_start.ne.buf(1).or.j_parent_start.ne.buf(2)) then write(s1,'(4i8)') i_parent_start,j_parent_start,buf call ATM_ANNOUNCE('ATM_TSTEP_INIT:'//trim(s1),3) end if !xxx call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- & !xxx & buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// & !xxx & s,rc) end if end if IF (gid.le.2) THEN !** innermost grid not active in coupling ** CALL ATM_SENDGRIDS(mype,num_pes,mpi_comm_comp,HLON,HLAT,VLON,VLAT) CALL ATM_SENDSLM(mype,num_pes,mpi_comm_comp,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 !rv call wrf_debug(2,message) endif RETURN end SUBROUTINE ATM_TSTEP_INIT !C !C*********************************************************************** !C SUBROUTINE ATM_RECVdtc(guessdtc) implicit none real,intent(in) :: guessdtc real(kind=kind_R) buf(1),dtc2dta integer ierr,i logical first/.true./ character*20 s SAVE 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 SUBROUTINE ATM_RECVdtc !C !C*********************************************************************** !C SUBROUTINE ATM_SENDGRIDS(mype,num_pes,mpi_comm_comp,HLON,HLAT,VLON,VLAT) implicit none integer, intent(in) :: mype,num_pes,mpi_comm_comp 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 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) !xxx call ASSEMBLE(mype,num_pes,mpi_comm_comp,ALONt,HLON,kind_lonlat) !xxx call ASSEMBLE(mype,num_pes,mpi_comm_comp,ALATt,HLAT,kind_lonlat) !xxx call ASSEMBLE(mype,num_pes,mpi_comm_comp,ALONv,VLON,kind_lonlat) !xxx call ASSEMBLE(mype,num_pes,mpi_comm_comp,ALATv,VLAT,kind_lonlat) call ASSEMBLE_lonlat(mype,num_pes,mpi_comm_comp,ALONt,HLON,kind_lonlat) call ASSEMBLE_lonlat(mype,num_pes,mpi_comm_comp,ALATt,HLAT,kind_lonlat) call ASSEMBLE_lonlat(mype,num_pes,mpi_comm_comp,ALONv,VLON,kind_lonlat) call ASSEMBLE_lonlat(mype,num_pes,mpi_comm_comp,ALATv,VLAT,kind_lonlat) call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2) call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat) !CoorR8 call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat) !CoorR8 call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat) !CoorR8 call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat) !CoorR8 call ATM_ANNOUNCE('the 4 grid arrays sent',1) call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2) return END SUBROUTINE ATM_SENDGRIDS !C !C*********************************************************************** !C SUBROUTINE ATM_SENDSLM(mype,num_pes,mpi_comm_comp,SLM) implicit none integer, intent(in) :: mype,num_pes,mpi_comm_comp 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 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(mype,num_pes,mpi_comm_comp,SLM_g,SLM,kind_SLM) call ATM_ANNOUNCE('(BP) to send SLM',2) call CMP_alt_SEND(SLM_g,NGP) call CMP_alt_SEND(SLM_g,NGP) ! 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 SUBROUTINE ATM_SENDSLM !C !C*********************************************************************** !C SUBROUTINE ATM_GETSST(mype,num_pes,mpi_comm_comp,SST,SLM) implicit none integer, intent(in) :: mype,num_pes,mpi_comm_comp 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 (.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(mype,num_pes,mpi_comm_comp,SST_g,SST,kind_SST) call CMP_alt_SEND(SST_g,NGP) call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2) end if call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3) call CMP_alt_RECV(SST_g,NGP) call DISASSEMBLE(mype,num_pes,mpi_comm_comp,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 SUBROUTINE ATM_GETSST !C !C*********************************************************************** !C SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & &TX,TY,PINT,PREC,U10,V10) implicit none real(kind=kind_sfcflux),dimension(ims:ime,jms:jme,kms:kme+1):: PINT real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: & &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PREC,U10,V10 ! Act. arg. for PINT is a 3d array - so this only is OK if ! Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:) !rv --- pint(1) is at top, and pint(lm+1) at surface. real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R real dtainv !C IF ( ia2o(1) .LT. 1 .and. ia2w(1) .LT. 1 ) RETURN IF (.not.PHYS) RETURN IF (gid.gt.2) RETURN 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 ! <- 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(1).eq.1) THEN !oooooooooooooooooooooooooooooo sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)-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,2)=sf(gid)%a(its:ite,jts:jte,2)+SWR(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)-TX(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)-TY(its:ite,jts:jte) ! <- signs for stress components are changed !ooooooooooooooooooooooooooooooooooo ELSE IF (Ocean_spec(1).eq.2) THEN !ooooooooooooooooooooooooooooooooooo sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)+PREC(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,2)=sf(gid)%a(its:ite,jts:jte,2)-TWBS(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,3)=sf(gid)%a(its:ite,jts:jte,3)-QWBS(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,4)=sf(gid)%a(its:ite,jts:jte,4)+PINT(its:ite,jts:jte,kme+1)-101300. sf(gid)%a(its:ite,jts:jte,5)=sf(gid)%a(its:ite,jts:jte,5)-SWR(its:ite,jts:jte)-RADOT(its:ite,jts:jte)+RLWIN(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,6)=sf(gid)%a(its:ite,jts:jte,6)-SWR(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)+TX(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)+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 !wwwwwwwwwwwwwwwwwwwwwwwww IF (WM_id(1).gt.0) THEN !wwwwwwwwwwwwwwwwwwwwwwwww sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)+U10(its:ite,jts:jte) sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)+V10(its:ite,jts:jte) !wwwwwwwwwww END IF !wwwwwwwwwww if (nrmSF) then sf(gid)%a=sf(gid)%a*dta2dtc end if call ATM_ANNOUNCE('ATM_DOFLUXES to return',3) return END SUBROUTINE ATM_DOFLUXES !C !C*********************************************************************** !C SUBROUTINE ATM_SENDFLUXES(mype,num_pes,mpi_comm_comp) implicit none integer, intent(in) :: mype,num_pes,mpi_comm_comp real(kind=kind_sfcflux) F(ids:idf,jds:jdf) integer n !C IF ( ia2o(1) .LT. 1 .and. ia2w(1) .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(mype,num_pes,mpi_comm_comp,F,sf(gid)%a(:,:,n),kind_sfcflux) call CMP_alt_SEND(F,NGP) end do call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3) return END SUBROUTINE ATM_SENDFLUXES !C !C*********************************************************************** !C SUBROUTINE ATM_ANNOUNCE(s,DbgLev) implicit none character*(*) s integer DbgLev integer ierr !C if (DbgLev.le.VerbLev) then if (s(1:5).eq.'(BP) ') then !rrr call MPI_BARRIER(MPI_COMM_Atmos,ierr) end if CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s) end if return END SUBROUTINE ATM_ANNOUNCE !C !C*********************************************************************** !C SUBROUTINE ASSEMBLE_lonlat(mype,num_pes,mpi_comm_comp,FG,FL,knd) implicit none real(kind=kind_lonlat),dimension(ids:idf,jds:jdf),intent(out):: FG real(kind=kind_lonlat),dimension(ims:ime,jms:jme),intent(in) :: FL integer, intent(in) :: knd integer, intent(in) :: mype,num_pes,mpi_comm_comp integer kl,kg ! kl=kind(FL) kg=kind(FG) if (knd.ne.kl .or. knd.ne.kg) then print*,'knd must = loc. and glob. kinds in ASSEMBLE. '// & & 'To generalize, call of QUILT_2 must be generalized ',knd,kl,kg call GLOB_ABORT(1,'wrong kinds in ASSEMBLE',1) end if call QUILT_2_lonlat(mype,num_pes,mpi_comm_comp, & &FL,FG,ids,idf,jds,jdf,kds,kde, & &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte) return END SUBROUTINE ASSEMBLE_lonlat !C !C*********************************************************************** !C SUBROUTINE ASSEMBLE(mype,num_pes,mpi_comm_comp,FG,FL,knd) implicit none real,dimension(ids:idf,jds:jdf),intent(out):: FG real,dimension(ims:ime,jms:jme),intent(in) :: FL integer, intent(in) :: knd integer, intent(in) :: mype,num_pes,mpi_comm_comp integer kl,kg ! kl=kind(FL) kg=kind(FG) if (knd.ne.kl .or. knd.ne.kg) then print*,'knd must = loc. and glob. kinds in ASSEMBLE. '// & & 'To generalize, call of QUILT_2 must be generalized ',knd,kl,kg call GLOB_ABORT(1,'wrong kinds in ASSEMBLE',1) end if call QUILT_2(mype,num_pes,mpi_comm_comp, & &FL,FG,ids,idf,jds,jdf,kds,kde, & &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte) return END SUBROUTINE ASSEMBLE !C !C*********************************************************************** !C SUBROUTINE DISASSEMBLE(mype,num_pes,mpi_comm_comp,FG,FL,knd) implicit none real,dimension(ids:idf,jds:jdf),intent(in) :: FG real,dimension(ims:ime,jms:jme),intent(out):: FL integer, intent(in) :: knd integer, intent(in) :: mype,num_pes,mpi_comm_comp integer kl,kg ! kl=kind(FL) kg=kind(FG) if (knd.ne.kl .or. knd.ne.kg) then print*,'knd must = loc. and glob. kinds in DISASSEMBLE. '// & & 'To generalize, call of PATCH must be generalized ',knd,kl,kg call GLOB_ABORT(1,'wrong kinds in DISASSEMBLE',1) end if call PATCH(mype,num_pes,mpi_comm_comp, & &FG,FL,ids,idf,jds,jdf,kds,kde, & &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte) return END SUBROUTINE DISASSEMBLE !C !C*********************************************************************** !C SUBROUTINE PATCH(MYPE,NUM_PES,MPI_COMM_COMP & &, ARRAYG,ARRAYL & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- ! PATCH DISTRIBUTES THE ELEMENTS OF REAL GLOBAL 2-D ARRAY ARRAYG TO ! THE REAL LOCAL 2-D ARRAY ARRAYL. ! ! AUTHOR: TOM BLACK !----------------------------------------------------------------------- ! IMPLICIT NONE ! !----------------------------------------------------------------------- ! INCLUDE "mpif.h" ! !----------------------------------------------------------------------- !*** ARGUMENT VARIABLES !----------------------------------------------------------------------- ! INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE & &, MYPE,NUM_PES,MPI_COMM_COMP ! REAL,DIMENSION(IDS:IDE,JDS:JDE),INTENT(IN) :: ARRAYG REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: ARRAYL ! !----------------------------------------------------------------------- !*** LOCAL VARIABLES !----------------------------------------------------------------------- ! REAL,ALLOCATABLE,DIMENSION(:) :: ARRAYX ! INTEGER :: I,IEND,IPE,IRECV,IRTN,ISEND,ISTART,J,JEND,JSTART,KNT & &, L,NUMVALS ! INTEGER,DIMENSION(4) :: LIMITS ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: ISTAT ! !----------------------------------------------------------------------- !*** INITIALIZE THE OUTPUT ARRAY !----------------------------------------------------------------------- ! DO J=JMS,JME DO I=IMS,IME ARRAYL(I,J)=0. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 FILLS ITS OWN LOCAL DOMAIN THEN PARCELS OUT ALL THE OTHER !*** PIECES TO THE OTHER TASKS. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- tasks : IF(MYPE==0)THEN !----------------------------------------------------------------------- ! DO J=JTS,JTE DO I=ITS,ITE ARRAYL(I,J)=ARRAYG(I,J) ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN !*** SENDS OUT THE APPROPRIATE PIECE OF THE GLOBAL ARRAY. !----------------------------------------------------------------------- ! DO IPE=1,NUM_PES-1 ! CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP & & ,ISTAT,IRECV) ! ISTART=LIMITS(1) IEND=LIMITS(2) JSTART=LIMITS(3) JEND=LIMITS(4) ! NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) KNT=0 ! DO J=JSTART,JEND DO I=ISTART,IEND KNT=KNT+1 ARRAYX(KNT)=ARRAYG(I,J) ENDDO ENDDO ! CALL MPI_SEND(ARRAYX,KNT,MPI_REAL,IPE,IPE,MPI_COMM_COMP,ISEND) ! DEALLOCATE(ARRAYX) ! ENDDO ! !----------------------------------------------------------------------- !*** ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND !*** RECEIVE THEIR PIECE OF THE GLOBAL ARRAY FROM TASK 0. !----------------------------------------------------------------------- ! ELSE ! LIMITS(1)=ITS LIMITS(2)=ITE LIMITS(3)=JTS LIMITS(4)=JTE ! CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND) ! NUMVALS=(ITE-ITS+1)*(JTE-JTS+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) ! CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP & &, ISTAT,IRECV) ! KNT=0 ! DO J=JTS,JTE DO I=ITS,ITE KNT=KNT+1 ARRAYL(I,J)=ARRAYX(KNT) ENDDO ENDDO ! DEALLOCATE(ARRAYX) ! !----------------------------------------------------------------------- ! ENDIF tasks ! !----------------------------------------------------------------------- ! END SUBROUTINE PATCH ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- SUBROUTINE QUILT_2(MYPE,NUM_PES,MPI_COMM_COMP & & ,ARRAYL,ARRAYG & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- ! QUILT_2 PULLS TOGETHER THE MPI TASKS' LOCAL ARRAYS ARRAYL AND ! THEN QUILTS THEM TOGETHER INTO A SINGLE GLOBAL ARRAY ARRAYG. ! ! AUTHOR: TOM BLACK !----------------------------------------------------------------------- ! IMPLICIT NONE ! !----------------------------------------------------------------------- ! INCLUDE "mpif.h" ! !----------------------------------------------------------------------- !*** ARGUMENT VARIABLES !----------------------------------------------------------------------- ! INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE & &, MYPE,NUM_PES,MPI_COMM_COMP ! REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ARRAYL REAL,DIMENSION(IDS:IDE,JDS:JDE),INTENT(OUT) :: ARRAYG ! !----------------------------------------------------------------------- !*** LOCAL VARIABLES !----------------------------------------------------------------------- ! REAL,ALLOCATABLE,DIMENSION(:) :: ARRAYX ! INTEGER :: I,IEND,IPE,IRECV,IRTN,ISEND,ISTART,J,JEND,JSTART,KNT & &, L,NUMVALS ! INTEGER,DIMENSION(4) :: LIMITS ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: ISTAT ! !----------------------------------------------------------------------- !*** INITIALIZE THE OUTPUT ARRAY !----------------------------------------------------------------------- ! DO J=JDS,JDE DO I=IDS,IDE ARRAYG(I,J)=0. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 FILLS ITS OWN PART OF THE GLOBAL FIRST. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- tasks : IF(MYPE==0)THEN !----------------------------------------------------------------------- ! DO J=JTS,JTE DO I=ITS,ITE ARRAYG(I,J)=ARRAYL(I,J) ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN !*** PULLS IN THE APPROPRIATE PIECES FROM ALL OTHER TASKS. !----------------------------------------------------------------------- ! DO IPE=1,NUM_PES-1 ! CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP & & ,ISTAT,IRECV) ! ISTART=LIMITS(1) IEND=LIMITS(2) JSTART=LIMITS(3) JEND=LIMITS(4) ! NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) ! CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,IPE,IPE,MPI_COMM_COMP & & ,ISTAT,IRECV) ! KNT=0 ! DO J=JSTART,JEND DO I=ISTART,IEND KNT=KNT+1 ARRAYG(I,J)=ARRAYX(KNT) ENDDO ENDDO ! DEALLOCATE(ARRAYX) ! ENDDO ! !----------------------------------------------------------------------- !*** ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND !*** SEND THEIR LOCAL ARRAY TO TASK 0. !----------------------------------------------------------------------- ! ELSE ! LIMITS(1)=ITS LIMITS(2)=ITE LIMITS(3)=JTS LIMITS(4)=JTE ! CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND) ! NUMVALS=(ITE-ITS+1)*(JTE-JTS+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) ! KNT=0 ! DO J=JTS,JTE DO I=ITS,ITE KNT=KNT+1 ARRAYX(KNT)=ARRAYL(I,J) ENDDO ENDDO ! CALL MPI_SEND(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP & &, ISEND) ! DEALLOCATE(ARRAYX) ! !----------------------------------------------------------------------- ! ENDIF tasks ! !----------------------------------------------------------------------- ! END SUBROUTINE QUILT_2 ! !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- SUBROUTINE QUILT_2_lonlat(MYPE,NUM_PES,MPI_COMM_COMP & ,ARRAYL,ARRAYG & ,IDS,IDE,JDS,JDE,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- ! QUILT_2 PULLS TOGETHER THE MPI TASKS' LOCAL ARRAYS ARRAYL AND ! THEN QUILTS THEM TOGETHER INTO A SINGLE GLOBAL ARRAY ARRAYG. ! ! AUTHOR: TOM BLACK !----------------------------------------------------------------------- ! IMPLICIT NONE ! !----------------------------------------------------------------------- ! INCLUDE "mpif.h" ! !----------------------------------------------------------------------- !*** ARGUMENT VARIABLES !----------------------------------------------------------------------- ! INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE & &, MYPE,NUM_PES,MPI_COMM_COMP ! REAL(kind=KIND_LONLAT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ARRAYL REAL(kind=KIND_LONLAT),DIMENSION(IDS:IDE,JDS:JDE),INTENT(OUT) :: ARRAYG ! !----------------------------------------------------------------------- !*** LOCAL VARIABLES !----------------------------------------------------------------------- ! REAL(kind=KIND_LONLAT),ALLOCATABLE,DIMENSION(:) :: ARRAYX ! INTEGER :: I,IEND,IPE,IRECV,IRTN,ISEND,ISTART,J,JEND,JSTART,KNT & &, L,NUMVALS ! INTEGER,DIMENSION(4) :: LIMITS ! INTEGER,DIMENSION(MPI_STATUS_SIZE) :: ISTAT ! !----------------------------------------------------------------------- !*** INITIALIZE THE OUTPUT ARRAY !----------------------------------------------------------------------- ! DO J=JDS,JDE DO I=IDS,IDE ARRAYG(I,J)=0. ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 FILLS ITS OWN PART OF THE GLOBAL FIRST. !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- tasks : IF(MYPE==0)THEN !----------------------------------------------------------------------- ! DO J=JTS,JTE DO I=ITS,ITE ARRAYG(I,J)=ARRAYL(I,J) ENDDO ENDDO ! !----------------------------------------------------------------------- !*** TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN !*** PULLS IN THE APPROPRIATE PIECES FROM ALL OTHER TASKS. !----------------------------------------------------------------------- ! DO IPE=1,NUM_PES-1 ! CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP & & ,ISTAT,IRECV) ! ISTART=LIMITS(1) IEND=LIMITS(2) JSTART=LIMITS(3) JEND=LIMITS(4) ! NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) ! CALL MPI_RECV(ARRAYX,NUMVALS,MPI_kind_lonlat,IPE,IPE,MPI_COMM_COMP & & ,ISTAT,IRECV) ! KNT=0 ! DO J=JSTART,JEND DO I=ISTART,IEND KNT=KNT+1 ARRAYG(I,J)=ARRAYX(KNT) ENDDO ENDDO ! DEALLOCATE(ARRAYX) ! ENDDO ! !----------------------------------------------------------------------- !*** ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND !*** SEND THEIR LOCAL ARRAY TO TASK 0. !----------------------------------------------------------------------- ! ELSE ! LIMITS(1)=ITS LIMITS(2)=ITE LIMITS(3)=JTS LIMITS(4)=JTE ! CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND) ! NUMVALS=(ITE-ITS+1)*(JTE-JTS+1) ALLOCATE(ARRAYX(NUMVALS),STAT=I) ! KNT=0 ! DO J=JTS,JTE DO I=ITS,ITE KNT=KNT+1 ARRAYX(KNT)=ARRAYL(I,J) ENDDO ENDDO ! CALL MPI_SEND(ARRAYX,NUMVALS,MPI_kind_lonlat,0,MYPE,MPI_COMM_COMP & &, ISEND) ! DEALLOCATE(ARRAYX) ! !----------------------------------------------------------------------- ! ENDIF tasks ! !----------------------------------------------------------------------- ! END SUBROUTINE QUILT_2_lonlat !----------------------------------------------------------------------- END MODULE ATM_cc ! !***********************************************************************