! module mpi_module ! ! Perform message-passing and related operations in distributed memory ! system, e.g., AIX. ! use params_module,only: nlat,nlonp4,nlon,nlevp1,ispval,nmlonp1, | nmlat,nmlev,nmagphrlat,nmagphrlon use fields_module,only: fields_4d,fields_3d,f4d,f3d, | nf4d,nf4d_hist,fsech,fsechmag,fsech2d,fsechmag2d,fsechmagphr2d, | dynpot,phim3d,foutput use hist_module,only: nfsech_geo,nfsech_mag,nfsech_geo2d, | nfsech_mag2d,nfsech_magphr use input_module,only: ntask_lat,ntask_lon implicit none #ifdef MPI #include "mpif.h" integer :: | irstat(MPI_STATUS_SIZE) ! mpi receive status #endif ! ! VT means vampir tracing: ! #ifdef VT #include "VT.inc" #endif ! integer :: | ntask, ! number of mpi tasks | ntaski, ! number of tasks in lon dimension (from input ntask_lat) | ntaskj, ! number of tasks in lat dimension (from input ntask_lon) | mytid, ! task id of current mpi task | mytidi, ! i coord for current task in task table | mytidj, ! j coord for current task in task table | lat0,lat1, ! first and last lats for each task | lon0,lon1, ! first and last lons for each task | mxlon,mxlat ! max of nlons,nlats owned by all tasks integer,allocatable :: | mylats(:), ! indices of lats I have | mylons(:) ! indices of lons I have integer,allocatable :: | itask_table(:,:) ! 2d table of tasks (i,j) ! ! Task type: type task integer :: mytid ! task id integer :: mytidi ! task coord in longitude dimension of task table integer :: mytidj ! task coord in latitude dimension of task table integer :: nlats ! number of latitudes calculated by this task integer :: nlons ! number of longitudes calculated by this task integer :: lat0,lat1 ! first and last latitude indices integer :: lon0,lon1 ! first and last longitude indices integer :: mylats(nlat ) ! lat indices (only lat0->lat1 are meaningful) integer :: mylons(nlonp4) ! lon indices (only lon0->lon1 are meaningful) end type task ! ! type(task) :: tasks(ntask) will be made available to all tasks ! (so each task has information about all tasks) ! type(task),allocatable :: tasks(:) ! ! Timing stats: logical :: do_rtc_mpi=.false. real :: tsec real :: rtc0_gather2root , rtcmp_gather2root =0., | rtc0_bndlats , rtcmp_bndlats =0., | rtc0_bndlats_f3d , rtcmp_bndlats_f3d =0., | rtc0_bndlons , rtcmp_bndlons =0., | rtc0_bndlons_f3d , rtcmp_bndlons_f3d =0., | rtc0_polelat , rtcmp_polelat =0., | rtc0_gatherlons , rtcmp_gatherlons =0., | rtc0_gatherlons_f3d , rtcmp_gatherlons_f3d =0., | rtc0_scatterlons , rtcmp_scatterlons =0., | rtc0_scatterlons_f3d , rtcmp_scatterlons_f3d =0., | rtc0_periodic_f4d , rtcmp_periodic_f4d =0., | rtc0_periodic_f3d , rtcmp_periodic_f3d =0., | rtc0_periodic_f2d , rtcmp_periodic_f2d =0., | rtc0_dynpot , rtcmp_dynpot =0. ! ! If not an mpi job, this module contains no subroutines. ! #ifdef MPI contains !----------------------------------------------------------------------- subroutine mp_init ! ! Initialize mpi and get ntask and mytid (called from tgcm.F before input): ! ! Local: integer :: ier,n,j,i ! #ifdef VT call vttraceoff(ier) #endif call mpi_init(ier) if (ier /= 0) write(6,"('>>> WARNING: error from mpi_init: ier=', | i4)") ier #ifdef VT call vtsetup() ! set user defined states and activities write(6,"('mp_init: starting vampir tracing..')") call vttraceon(ier) ! start vampir tracing #endif call mpi_comm_size(MPI_COMM_WORLD,ntask,ier) if (ier /= 0) write(6,"('>>> WARNING: error from mpi_comm_size:', | ' ier=',i4)") ier call mpi_comm_rank(MPI_COMM_WORLD,mytid,ier) if (ier /= 0) write(6,"('>>> WARNING: error from mpi_comm_rank:', | ' ier=',i4)") ier ! ! Allocate array of tasks (user defined type(task)): allocate(tasks(0:ntask-1),stat=ier) if (ier /= 0) then write(6,"('>>> mp_init: error allocating tasks(',i3,')')") | ntask call mp_close stop 'tasks' endif end subroutine mp_init !----------------------------------------------------------------------- subroutine mp_distribute ! ! Set up 2-d data decomposition in lat,lon. Define structure array ! tasks(ntasks). This is broadcast (mpi_alltoall) to all tasks, ! so every task has access to info for all tasks. ! ! Set by mp_init: ! ntask: Number of mpi tasks this run (from mp_init) ! mytid: id of current task (from mp_init) ! ! Set by input (ntask_lon,lat are defined on input to this routine): ! ntask_lon = ntaski: Number of tasks in longitude direction ! ntask_lat = ntaskj: Number of tasks in latitude direction ! ! Set by this routine: ! itask_table(ntaski,ntaskj): 2d table of tasks ! mytidi: i-coord of current task in task table ! mytidj: j-coord of current task in task table ! lat0,lat1: starting and ending indices in latitude for current task ! lon0,lon1: starting and ending indices in longitude for current task ! mylats,mylons: indices to lats and lons for current tasks ! ! tasks(ntasks): array of task types. ! (note mytidi,j,lat0,1,lon0,1,mylats,lons above are redundant with ! tasks(mytid), eg, tasks(mytid)%mytidi==mytidi) ! ! Local: integer :: i,j,n,ier,irank,nj,ni,ncells ! ! itasks_send(len_task_type,ntask) will be used to send tasks(:) info ! to all tasks (directly passing mpi derived data types is reportedly ! not stable, or not available until MPI 2.x). ! integer,parameter :: len_task_type = nlat+nlonp4+9 integer :: itask_packed(len_task_type) integer,allocatable :: | itasks_send(:,:), ! send buffer | itasks_recv(:,:) ! send buffer ! ! Set ntaski,j from input ntask_lon,ntask_lat: ntaski = ntask_lon ntaskj = ntask_lat ! ! ntaski*ntaskj must == ntask ! (This was already checked in input, but you never know...) if (ntaski*ntaskj /= ntask) then write(6,"('>>> mp_distribute: ntaski*ntaskj must == ntask.')") write(6,"(' ntaski=',i3,' ntaskj=',i3,' ntask=',i3)") | ntaski,ntaskj,ntask stop 'ntaski*j' endif ! ! Allocate and set 2d table of tasks: allocate(itask_table(-1:ntaski,-1:ntaskj),stat=ier) if (ier /= 0) then write(6,"('>>> Error allocating itable: ntaski,j=',2i3)") | ntaski,ntaskj call mp_close stop 'itask_table' endif itask_table(:,:) = MPI_PROC_NULL irank = 0 do j = 0,ntaskj-1 do i = 0,ntaski-1 itask_table(i,j) = irank if (mytid == irank) then mytidi = i mytidj = j endif irank = irank+1 enddo enddo ! ! Print table to stdout: write(6,"(/,'ntask=',i3,' ntaski=',i2,' ntaskj=',i2, | ' Task Table:')") ntask,ntaski,ntaskj do j=-1,ntaskj write(6,"('j=',i3,' itask_table(:,j)=',100i3)") | j,itask_table(:,j) enddo ! ! Calculate start and end indices in lon,lat dimensions for each task: call distribute_1d(1,nlonp4,ntaski,mytidi,lon0,lon1) call distribute_1d(1,nlat ,ntaskj,mytidj,lat0,lat1) nj = lat1-lat0+1 ! number of latitudes for this task ni = lon1-lon0+1 ! number of longitudes for this task ncells = nj*ni ! total number of grid cells for this task ! ! Report my stats to stdout: write(6,"(/,'mytid=',i3,' mytidi,j=',2i3,' lat0,1=',2i3,' (',i2, | ') lon0,1=',2i3,' (',i2,') ncells=',i4)") | mytid,mytidi,mytidj,lat0,lat1,nj,lon0,lon1,ni,ncells ! ! Set mylats, mylons: allocate(mylats(nj),stat=ier) if (ier /= 0) then write(6,"('>>> Error allocating mylats(nj=',i2,'): ier=',i3)") | nj,ier endif do j=1,nj mylats(j) = lat0+j-1 enddo ! allocate(mylons(ni),stat=ier) if (ier /= 0) then write(6,"('>>> Error allocating mylons(ni=',i2,'): ier=',i3)") | ni,ier endif do i=1,ni mylons(i) = lon0+i-1 enddo ! ! Define all task structures with current task values ! (redundant for alltoall): ! do n=0,ntask-1 tasks(n)%mytid = mytid tasks(n)%mytidi = mytidi tasks(n)%mytidj = mytidj tasks(n)%nlats = nj tasks(n)%nlons = ni tasks(n)%lat0 = lat0 tasks(n)%lat1 = lat1 tasks(n)%lon0 = lon0 tasks(n)%lon1 = lon1 tasks(n)%mylats(:) = ispval ! init tasks(n)%mylons(:) = ispval ! init do j=lat0,lat1 tasks(n)%mylats(j) = j enddo do i=lon0,lon1 tasks(n)%mylons(i) = i enddo enddo ! ! Pack tasks(mytid) into itasks_send: allocate(itasks_send(len_task_type,0:ntask-1),stat=ier) if (ier /= 0) then write(6,"('>>> Error allocating itasks_send: len_task_type=', | i3,' ntask=',i3)") len_task_type,ntask endif allocate(itasks_recv(len_task_type,0:ntask-1),stat=ier) if (ier /= 0) then write(6,"('>>> Error allocating itasks_recv: len_task_type=', | i3,' ntask=',i3)") len_task_type,ntask endif do n=0,ntask-1 itasks_send(1,n) = tasks(mytid)%mytid itasks_send(2,n) = tasks(mytid)%mytidi itasks_send(3,n) = tasks(mytid)%mytidj itasks_send(4,n) = tasks(mytid)%nlats itasks_send(5,n) = tasks(mytid)%nlons itasks_send(6,n) = tasks(mytid)%lat0 itasks_send(7,n) = tasks(mytid)%lat1 itasks_send(8,n) = tasks(mytid)%lon0 itasks_send(9,n) = tasks(mytid)%lon1 itasks_send(10:10+nlat-1,n) = tasks(mytid)%mylats(:) i = 10+nlat itasks_send(i:i+nlonp4-1,n) = tasks(mytid)%mylons(:) enddo ! ! Send itasks_send and receive itasks_recv: call mpi_alltoall(itasks_send,len_task_type,MPI_INTEGER, | itasks_recv,len_task_type,MPI_INTEGER, | MPI_COMM_WORLD,ier) if (ier /= 0) | call handle_mpi_err(ier,'mpi_alltoall to send/recv itasks') ! ! Unpack itasks_recv into tasks(n) and report to stdout: do n=0,ntask-1 tasks(n)%mytid = itasks_recv(1,n) tasks(n)%mytidi = itasks_recv(2,n) tasks(n)%mytidj = itasks_recv(3,n) tasks(n)%nlats = itasks_recv(4,n) tasks(n)%nlons = itasks_recv(5,n) tasks(n)%lat0 = itasks_recv(6,n) tasks(n)%lat1 = itasks_recv(7,n) tasks(n)%lon0 = itasks_recv(8,n) tasks(n)%lon1 = itasks_recv(9,n) tasks(n)%mylats(:) = itasks_recv(10:10+nlat-1,n) i = 10+nlat tasks(n)%mylons(:) = itasks_recv(i:i+nlonp4-1,n) ! if (n==mytid) then write(6,"(/,'Task ',i3,':')") n write(6,"('tasks(',i3,')%mytid =',i3)") n,tasks(n)%mytid write(6,"('tasks(',i3,')%mytidi=',i3)") n,tasks(n)%mytidi write(6,"('tasks(',i3,')%mytidj=',i3)") n,tasks(n)%mytidj write(6,"('tasks(',i3,')%nlats =',i3)") n,tasks(n)%nlats write(6,"('tasks(',i3,')%nlons =',i3)") n,tasks(n)%nlons write(6,"('tasks(',i3,')%lat0 =',i3)") n,tasks(n)%lat0 write(6,"('tasks(',i3,')%lat1 =',i3)") n,tasks(n)%lat1 write(6,"('tasks(',i3,')%lon0 =',i3)") n,tasks(n)%lon0 write(6,"('tasks(',i3,')%lon1 =',i3)") n,tasks(n)%lon1 write(6,"('tasks(',i3,')%mylats=',/,(15i4))") | n,tasks(n)%mylats(tasks(n)%lat0:tasks(n)%lat1) write(6,"('tasks(',i3,')%mylons=',/,(15i4))") | n,tasks(n)%mylons(tasks(n)%lon0:tasks(n)%lon1) endif enddo ! ! Release locally allocated space: deallocate(itasks_send) deallocate(itasks_recv) ! ! All tasks must have at least 4 longitudes: do n=0,ntask-1 if (tasks(n)%nlons < 4) then write(6,"(/,'>>> mp_distribute: each task must carry ', | 'at least 4 longitudes. task=',i2,' nlons=',i2)") | n,tasks(n)%nlons stop 'nlons per task' endif enddo ! ! mxlon,mxlat are maximum number of lons,lats owned by all tasks: mxlon = -9999 do n=0,ntask-1 if (tasks(n)%nlons > mxlon) mxlon = tasks(n)%nlons enddo mxlat = -9999 do n=0,ntask-1 if (tasks(n)%nlats > mxlat) mxlat = tasks(n)%nlats enddo ! ! For debug: ! call mp_close ! stop 'mp_distribute' ! end subroutine mp_distribute !----------------------------------------------------------------------- subroutine distribute_1d(n1,n2,nprocs,myrank,istart,iend) ! ! Distribute work across a 1d vector(n1->n2) to nprocs. ! Return start and end indices for proc myrank. ! ! Args: integer,intent(in) :: n1,n2,nprocs,myrank integer,intent(out) :: istart,iend ! ! Local: integer :: lenproc,iremain,n ! n = n2-n1+1 lenproc = n/nprocs iremain = mod(n,nprocs) istart = n1 + myrank*lenproc + min(myrank,iremain) iend = istart+lenproc-1 if (iremain > myrank) iend = iend+1 ! end subroutine distribute_1d !----------------------------------------------------------------------- subroutine mp_gather2root(ixt,type) ! ! Master task must collect all data (except its own) into its prognostic ! fields f4d(:)%data prior to writing a history. Slaves send their ! (lon0:lon1,nlevp1,lat0:lat1) data to the root task. ! If type == 'prim', pass prognostics f4d(:)%data for primary histories. ! If type == 'sech', pass diagnostic fsech(:)%data for secondary histories. ! ! Args: integer,intent(in) :: ixt ! ! type=='prim' if primary history data (f4d(:)), secondary ('sech') ! data (fsech(:)) otherwise. ! character(len=*),intent(in) :: type ! if (do_rtc_mpi) call timer(rtc0_gather2root,tsec,'begin') ! ! Dividing collecting into primary and secondary histories if (trim(type)=='prim') then call mp_gather2root_prim(ixt,type) elseif(trim(type)=='sech') then call mp_gather2root_sech(ixt,type) else write(6,"('mp_gather2root: unknown type ',a,' should be prim ', | 'or sech')") stop 'mp_gather2root' endif ! if (do_rtc_mpi) then call timer(rtc0_gather2root,tsec,'end') rtcmp_gather2root = rtcmp_gather2root+tsec endif ! end subroutine mp_gather2root !----------------------------------------------------------------------- subroutine mp_gather2root_prim(ixt,type) ! ! Master task must collect all data (except its own) into its prognostic ! fields f4d(:)%data prior to writing a history. Slaves send their ! (lon0:lon1,nlevp1,lat0:lat1) data to the root task. ! If type == 'prim', pass prognostics f4d(:)%data for primay histories. ! ! Args: integer,intent(in) :: ixt ! ! type=='prim' if primary history data (f4d(:)) ! character(len=*),intent(in) :: type ! ! Local: integer :: isrc,ireqrecv,ireqsend,ier,n,i,j,k,l,len, | ilon0,ilon1,ilat0,ilat1,nlons,nlats,msgtag integer :: idest = 0 real :: fmin,fmax real,allocatable :: rcvbuf(:,:,:,:),sndbuf(:,:,:,:) ! ! Allocate send and receive buffers: ! (mxlon,mxlat are max number of lons,lats held by all tasks) ! ! Prognostics (primary history data f4d(i)%data(k,i,j,ixt): allocate(rcvbuf(nlevp1,mxlon,mxlat,nf4d),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gather2root: error allocating rcvbuf:', | ' mxlon=',i3,' nlevp1=',i3,' mxlat=',i3,' nf4d=',i3, | ' ier=',i4)") mxlon,nlevp1,mxlat,nf4d,ier allocate(sndbuf(nlevp1,mxlon,mxlat,nf4d),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gather2root: error allocating sndbuf:', | ' mxlon=',i3,' nlevp1=',i3,' mxlat=',i3,' nf4d=',i3, | ' ier=',i4)") mxlon,nlevp1,mxlat,nf4d,ier len = nlevp1*mxlon*mxlat*nf4d ! buffer length ! ! ! Root receives from all other tasks: if (mytid==0) then ! root task ! ! If primary history, root task defines foutput at its own subdomain: do i=1,nf4d foutput(:,lon0:lon1,lat0:lat1,i) = | f4d(i)%data(:,lon0:lon1,lat0:lat1,ixt) ! call fminmax( ! | foutput(:,lon0:lon1,lat0:lat1,i), ! | (lon1-lon0+1)*nlevp1*(lat1-lat0+1),fmin,fmax) ! write(6,"('Root copies its own domain into foutput: i=', ! | i3,' min,max=',2e12.4)") i,fmin,fmax enddo ! ! Receive subdomains from slave tasks: do n=1,ntask-1 ! receive from slaves only msgtag = n call mpi_irecv(rcvbuf,len,MPI_REAL8,n,msgtag,MPI_COMM_WORLD, | ireqrecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gather2root irecv from n') ! ! Wait for receives to complete: call mpi_wait(ireqrecv,irstat,ier) if (ier /= 0) then call handle_mpi_err(ier,'mp_gather2root wait for n') else ! write(6,"('mp_gather2root: root received from task ',i3)") n endif ! ! Transfer from receive buffer to fields: ilon0 = tasks(n)%lon0 ilon1 = tasks(n)%lon1 ilat0 = tasks(n)%lat0 ilat1 = tasks(n)%lat1 nlons = ilon1-ilon0+1 nlats = ilat1-ilat0+1 do i=1,nf4d ! ! Root task stores data in full 3d grid array foutput. This is a pointer ! declared in fields module (fields.F), and allocated by the root task ! only in sub allocdata: foutput(nlevp1,nlonp4,nlat,nf4d). ! foutput(:,ilon0:ilon1,ilat0:ilat1,i) = | rcvbuf(:,1:nlons,1:nlats,i) ! call fminmax( ! | foutput(:,ilon0:ilon1,ilat0:ilat1,i),nlons*nlevp1*nlats, ! | fmin,fmax) ! if (i==1) write(6,"(' ')") ! write(6,"('mp_gather2root: received field ',i3, ! | ' from task ',i3,' fmin,max=',2e12.4)") i,n,fmin,fmax enddo ! i=1,nf4d ! enddo ! n=1,ntask-1 ! ! Non-root tasks send to master: else ! ! Load send buffer: sndbuf(:,:,:,:) = 0. nlons = lon1-lon0+1 nlats = lat1-lat0+1 ! ! Prognostic fields: do i=1,nf4d sndbuf(:,1:nlons,1:nlats,i) = | f4d(i)%data(:,lon0:lon1,lat0:lat1,ixt) ! call fminmax(sndbuf(:,1:nlons,1:nlats,i),nlons*nlevp1*nlats, ! | fmin,fmax) ! write(6,"('mp_gather2root: task ',i3,' sending prog field ', ! | i2,' to root: fmin,max=',2e12.4)") mytid,i,fmin,fmax enddo ! ! Send to root: msgtag = mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,msgtag,MPI_COMM_WORLD, | ireqsend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gather2root isend to root') ! ! Wait for send to complete: call mpi_wait(ireqsend,irstat,ier) if (ier /= 0) then call handle_mpi_err(ier, | 'mp_gather2root wait for send to root') endif endif ! root or slave ! ! Release local buffer space: deallocate(rcvbuf) deallocate(sndbuf) ! end subroutine mp_gather2root_prim !----------------------------------------------------------------------- subroutine mp_gather2root_sech(ixt,type) ! ! Master task must collect all data (except its own) into its prognostic ! fields f4d(:)%data prior to writing a history. Slaves send their ! (lon0:lon1,nlevp1,lat0:lat1) data to the root task. ! If type == 'sech', pass diagnostic fsech(:)%data for secondary histories. ! ! Args: integer,intent(in) :: ixt ! ! secondary ('sech') data (fsech(:)) otherwise. ! character(len=*),intent(in) :: type ! ! Local: integer :: isrc,ireqrecv,ireqsend,ier,n,i,j,k,l,len, | ilon0,ilon1,ilat0,ilat1,nlons,nlats,msgtag, | mx_nfsech,mxlev,start_nf,end_nf,dif_nf integer :: idest = 0 real :: fmin,fmax real,allocatable :: rcvbuf(:,:,:,:),sndbuf(:,:,:,:) ! ! Allocate send and receive buffers: ! (mxlon,mxlat are max number of lons,lats held by all tasks) ! check for magnetic coordinates nmlat,nmlon & magnetospheric ! nmagphrlat,nmagphrlon and also number of height levels ! since dynamo is not parallel so far don't take coord size from tasks ! calculate size of rcvbuf ! mxlev = nlevp1 mx_nfsech = nfsech_geo + nfsech_geo2d ! ! secondary history data fsech(i)%data(nlevp1,nlonp4,nlat) ! fsechmag(i)%data(nlevp1+3,nmlonp1,nmlat) ! fsech2d(i)%data(nlonp4,nlat) ! fsechmag2d(i)%data(nmlonp1,nmlat) ! fsechmagphr2d(i)%data(nmagphrlon,nmagphrlat) ! allocate(rcvbuf(mxlev,mxlon,mxlat,mx_nfsech),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gather2root_sech: error allocating rcvbuf:', | ' mxlon=',i3,' mxlev=',i3,' mxlat=',i3,' mx_nfsech=', | i3,' ier=',i4)") mxlon,mxlev,mxlat,mx_nfsech,ier allocate(sndbuf(mxlev,mxlon,mxlat,mx_nfsech),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gather2root_sech: error allocating sndbuf:', | ' mxlon=',i3,' mxlev=',i3,' mxlat=',i3,' mx_nfsech=', | i3,' ier=',i4)") mxlon,mxlev,mxlat,mx_nfsech,ier len = mxlev*mxlon*mxlat*mx_nfsech ! buffer length ! ! Root receives from all other tasks: if (mytid==0) then ! root task ! ! Receive subdomains from slave tasks: ! don't process the mag & magphr fields, since they are only known by the ! master task - so the gather is not done do n=1,ntask-1 ! receive from slaves only msgtag = n call mpi_irecv(rcvbuf,len,MPI_REAL8,n,msgtag,MPI_COMM_WORLD, | ireqrecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gather2root_sech irecv from n') ! ! Wait for receives to complete: call mpi_wait(ireqrecv,irstat,ier) if (ier /= 0) then call handle_mpi_err(ier,'mp_gather2root_sec wait for n') else ! write(6,"('mp_gather2root: root received from task ',i3)") n endif ! ! Transfer from receive buffer to fields: ilon0 = tasks(n)%lon0 ilon1 = tasks(n)%lon1 ilat0 = tasks(n)%lat0 ilat1 = tasks(n)%lat1 nlons = ilon1-ilon0+1 nlats = ilat1-ilat0+1 ! ! Load 3d geographic secondary history fields from receive buffer: start_nf = 1 end_nf = nfsech_geo do i= start_nf,end_nf if (.not.fsech(i)%task0_only) then do j=1,nlats do l=1,nlons fsech(i)%data(1:nlevp1,ilon0+l-1,ilat0+j-1) = | rcvbuf(1:nlevp1,l,j,i) enddo enddo endif enddo ! i=1,nfsech_geo start_nf = nfsech_geo+1 end_nf = nfsech_geo+nfsech_geo2d dif_nf = nfsech_geo do i= start_nf,end_nf if (.not.fsech2d(i)%task0_only) then do j=1,nlats do l=1,nlons fsech2d(i-dif_nf)%data(ilon0+l-1,ilat0+j-1) = | rcvbuf(1,l,j,i) enddo enddo endif enddo ! nfsech_geo2d enddo ! n=1,ntask-1 ! ! Non-root tasks send to master: else ! ! Load send buffer: sndbuf(:,:,:,:) = 0. nlons = lon1-lon0+1 nlats = lat1-lat0+1 ! ! Load 3d geographic secondary history fields to send buffer: start_nf = 1 end_nf = nfsech_geo do i= start_nf,end_nf if (.not.fsech2d(i)%task0_only) then do j=1,nlats do l=1,nlons sndbuf(1:nlevp1,l,j,i) = | fsech(i)%data(1:nlevp1,lon0+l-1,lat0+j-1) enddo enddo endif enddo ! i=1,nfsech_geo start_nf = nfsech_geo+1 end_nf = nfsech_geo+nfsech_geo2d dif_nf = nfsech_geo do i= start_nf,end_nf if (.not.fsech2d(i-dif_nf)%task0_only) then do j=1,nlats do l=1,nlons sndbuf(1,l,j,i) = | fsech2d(i-dif_nf)%data(lon0+l-1,lat0+j-1) enddo enddo endif enddo ! nfsech_geo2d ! ! Send to root: msgtag = mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,msgtag,MPI_COMM_WORLD, | ireqsend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gather2root isend to root') ! ! Wait for send to complete: call mpi_wait(ireqsend,irstat,ier) if (ier /= 0) then call handle_mpi_err(ier, | 'mp_gather2root wait for send to root') endif endif ! root or slave ! ! Release local buffer space: deallocate(rcvbuf) deallocate(sndbuf) ! end subroutine mp_gather2root_sech !----------------------------------------------------------------------- subroutine mp_bndlats(f,mxf,ixt) ! ! Exchange boundary latitude data between tasks. ! Each task sends its lat0,lat0+1 data to task jprev, and its lat1-1,lat1 ! data to jnext. ! Each task receives its lat0-2,lat0-1 data from task jprev, and its ! lat1+1,lat1+2 data from task jnext. ! ! Args: integer,intent(in) :: ixt,mxf type(fields_4d),intent(inout) :: f(mxf) ! assume 4d data in f(n)%data ! ! Local: integer :: n,nn,nlons,ier,len,jnext,jprev,nflds,jsend0,jsend1, | jrecv0,jrecv1,lendat real,allocatable :: | sndbuf0(:,:,:,:), ! send buffer for lat0 ,lat0+1 (k,i,2,nf) | sndbuf1(:,:,:,:), ! send buffer for lat1-1,lat1 (k,i,2,nf) | rcvbuf0(:,:,:,:), ! recv buffer for lat0-2,lat0-1 (k,i,2,nf) | rcvbuf1(:,:,:,:) ! recv buffer for lat1+1,lat1+2 (k,i,2,nf) real :: fmin,fmax ! #ifdef VT ! call vtsymdef(100, 'mp_bndlats','Communication',ier) call vtbegin(100,ier) #endif if (do_rtc_mpi) call timer(rtc0_bndlats,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): nlons = lon1-lon0+1 nflds = 0 do n=1,mxf if (f(n)%mpi) nflds = nflds+1 enddo if (nflds==0) then write(6,"('>>> WARNING mp_bndlats: no f(:)%mpi are true --', | ' returning.')") return endif allocate(sndbuf0(nlevp1,nlons,2,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats: error allocating sndbuf0.')") allocate(sndbuf1(nlevp1,nlons,2,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats: error allocating sndbuf1.')") allocate(rcvbuf0(nlevp1,nlons,2,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats: error allocating rcvbuf0.')") allocate(rcvbuf1(nlevp1,nlons,2,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats: error allocating rcvbuf1.')") len = nlevp1*nlons*2*nflds lendat = nlevp1*nlons*2 ! ! Locate adjacent tasks (includes null tasks top and bottom) jprev = itask_table(mytidi,mytidj-1) ! task above (south) jnext = itask_table(mytidi,mytidj+1) ! task below (north) ! ! Load sndbuf0 with lat0,lat0+1 and sndbuf1 with lat1-1,lat1: nn = 0 do n=1,mxf if (f(n)%mpi) then nn = nn+1 sndbuf0(:,:,:,nn) = f(n)%data(:,lon0:lon1,lat0:lat0+1,ixt) sndbuf1(:,:,:,nn) = f(n)%data(:,lon0:lon1,lat1-1:lat1,ixt) ! call fminmax(sndbuf0(:,:,:,nn),lendat,fmin,fmax) ! write(6,"('bndlats: sndbuf0 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax ! call fminmax(sndbuf1(:,:,:,nn),lendat,fmin,fmax) ! write(6,"('bndlats: sndbuf1 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif enddo ! ! Send lat0:lat0+1 (sndbuf0) to jprev: call mpi_isend(sndbuf0,len,MPI_REAL8,jprev,1,MPI_COMM_WORLD, | jsend0,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats send0 to jprev') ! ! Send lat1-1:lat1 (sndbuf1) to jnext: call mpi_isend(sndbuf1,len,MPI_REAL8,jnext,1,MPI_COMM_WORLD, | jsend1,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats send1 to jnext') ! ! Receive lat0-2:lat0-1 (rcvbuf0) from jprev: call mpi_irecv(rcvbuf0,len,MPI_REAL8,jprev,1,MPI_COMM_WORLD, | jrecv0,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats recv0 fm jprev') ! ! Receive lat1+1:lat1+2 (rcvbuf1) from jnext: call mpi_irecv(rcvbuf1,len,MPI_REAL8,jnext,1,MPI_COMM_WORLD, | jrecv1,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats recv1 fm jnext') ! ! Wait for completions: call mpi_wait(jsend0,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats wait for send0') call mpi_wait(jsend1,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats wait for send1') call mpi_wait(jrecv0,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats wait for recv0') call mpi_wait(jrecv1,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlats wait for recv1') ! ! Copy lat0-2:lat0-1 from rcvbuf0, and lat1+1:lat1+2 from rcvbuf1: nn = 0 do n=1,mxf if (f(n)%mpi) then nn = nn+1 if (lat0 /= 1) then f(n)%data(:,lon0:lon1,lat0-2:lat0-1,ixt) = | rcvbuf0(:,:,:,nn) ! call fminmax(f(n)%data(lon0:lon1,:,lat0-2:lat0-1,ixt), ! | lendat,fmin,fmax) ! write(6,"('bndlats: rcvbuf0 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif if (lat1 /= nlat) then f(n)%data(:,lon0:lon1,lat1+1:lat1+2,ixt) = | rcvbuf1(:,:,:,nn) ! call fminmax(f(n)%data(lon0:lon1,:,lat1+1:lat1+2,ixt), ! | lendat,fmin,fmax) ! write(6,"('bndlats: rcvbuf1 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif endif enddo ! ! Release local buffer space: deallocate(sndbuf0) deallocate(sndbuf1) deallocate(rcvbuf0) deallocate(rcvbuf1) ! if (do_rtc_mpi) then call timer(rtc0_bndlats,tsec,'end') rtcmp_bndlats = rtcmp_bndlats+tsec endif #ifdef VT ! call vtsymdef(100, 'mp_bndlats','Communication',ier) call vtend(100,ier) #endif end subroutine mp_bndlats !----------------------------------------------------------------------- subroutine mp_bndlats_f3d(f,id1,i0,i1,j0,j1,nf) ! ! Exchange boundary latitude data between tasks. ! Each task sends its lat0,lat0+1 data to task jprev, and its lat1-1,lat1 ! data to jnext. ! Each task receives its lat0-2,lat0-1 data from task jprev, and its ! lat1+1,lat1+2 data from task jnext. ! ! Args: integer,intent(in) :: id1,i0,i1,j0,j1,nf real,intent(inout) :: f(id1,i0:i1,j0-2:j1+2,nf) ! ! Local: integer :: n,nn,nlons,ier,len,jnext,jprev,nflds,jsend0,jsend1, | jrecv0,jrecv1,lendat real,allocatable :: | sndbuf0(:,:,:,:), ! send buffer for j0 ,j0+1 (k,i,2,nf) | sndbuf1(:,:,:,:), ! send buffer for j1-1,j1 (k,i,2,nf) | rcvbuf0(:,:,:,:), ! recv buffer for j0-2,j0-1 (k,i,2,nf) | rcvbuf1(:,:,:,:) ! recv buffer for j1+1,j1+2 (k,i,2,nf) real :: fmin,fmax ! #ifdef VT ! call vtsymdef(100, 'mp_bndlats_f3d','Communication',ier) call vtbegin(100,ier) #endif if (do_rtc_mpi) call timer(rtc0_bndlats_f3d,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): nlons = i1-i0+1 allocate(sndbuf0(id1,nlons,2,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats_f3d: error allocating sndbuf0.')") allocate(sndbuf1(id1,nlons,2,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats_f3d: error allocating sndbuf1.')") allocate(rcvbuf0(id1,nlons,2,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats_f3d: error allocating rcvbuf0.')") allocate(rcvbuf1(id1,nlons,2,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlats_f3d: error allocating rcvbuf1.')") len = id1*nlons*2*nf lendat = id1*nlons*2 ! ! Locate adjacent tasks (includes null tasks top and bottom) jprev = itask_table(mytidi,mytidj-1) ! task above (south) jnext = itask_table(mytidi,mytidj+1) ! task below (north) ! ! Load sndbuf0 with j0,j0+1 and sndbuf1 with j1-1,j1: do n=1,nf sndbuf0(:,:,:,n) = f(:,i0:i1,j0 :j0+1,n) sndbuf1(:,:,:,n) = f(:,i0:i1,j1-1:j1 ,n) call fminmax(sndbuf0(:,:,:,n),lendat,fmin,fmax) write(6,"('bndlats_f3d: sndbuf0 field ',i2,' min,max=',2e12.4)") | n,fmin,fmax call fminmax(sndbuf1(:,:,:,n),lendat,fmin,fmax) write(6,"('bndlats_f3d: sndbuf1 field ',i2,' min,max=',2e12.4)") | n,fmin,fmax enddo ! ! Send j0:j0+1 (sndbuf0) to jprev: call mpi_isend(sndbuf0,len,MPI_REAL8,jprev,1,MPI_COMM_WORLD, | jsend0,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d send0 to jprev') ! ! Send j1-1:j1 (sndbuf1) to jnext: call mpi_isend(sndbuf1,len,MPI_REAL8,jnext,1,MPI_COMM_WORLD, | jsend1,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d send1 to jnext') ! ! Receive j0-2:j0-1 (rcvbuf0) from jprev: call mpi_irecv(rcvbuf0,len,MPI_REAL8,jprev,1,MPI_COMM_WORLD, | jrecv0,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d recv0 fm jprev') ! ! Receive j1+1:j1+2 (rcvbuf1) from jnext: call mpi_irecv(rcvbuf1,len,MPI_REAL8,jnext,1,MPI_COMM_WORLD, | jrecv1,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d recv1 fm jnext') ! ! Wait for completions: call mpi_wait(jsend0,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d wait for send0') call mpi_wait(jsend1,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d wait for send1') call mpi_wait(jrecv0,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d wait for recv0') call mpi_wait(jrecv1,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlats_f3d wait for recv1') ! ! Copy j0-2:j0-1 from rcvbuf0, and j1+1:j1+2 from rcvbuf1: do n=1,nf if (j0 /= 1) then f(:,i0:i1,j0-2:j0-1,n) = rcvbuf0(:,:,:,n) call fminmax(f(:,i0:i1,j0-2:j0-1,n),lendat,fmin,fmax) write(6,"('bndlats_f3d: rcvbuf0 field ',i2,' min,max=', | 2e12.4)") n,fmin,fmax endif if (j1 /= nlat) then f(:,i0:i1,j1+1:j1+2,n) = rcvbuf1(:,:,:,n) call fminmax(f(:,i0:i1,j1+1:j1+2,n),lendat,fmin,fmax) write(6,"('bndlats_f3d: rcvbuf1 field ',i2,' min,max=', | 2e12.4)") n,fmin,fmax endif enddo ! ! Release local buffer space: deallocate(sndbuf0) deallocate(sndbuf1) deallocate(rcvbuf0) deallocate(rcvbuf1) ! if (do_rtc_mpi) then call timer(rtc0_bndlats_f3d,tsec,'end') rtcmp_bndlats_f3d = rtcmp_bndlats_f3d+tsec endif #ifdef VT ! call vtsymdef(100, 'mp_bndlats_f3d','Communication',ier) call vtend(100,ier) #endif end subroutine mp_bndlats_f3d !----------------------------------------------------------------------- subroutine mp_bndlons(f,mxf,ixt) ! ! Exchange boundary longitude data between tasks. ! Each task sends its lon0,lon0+1 data to task iprev, and its lon1-1,lon1 ! data to inext. ! Each task receives its lon0-2,lon0-1 data from task iprev, and its ! lon1+1,lon1+2 data from task inext. ! Because of periodic points, lons -1,0 and nlonp4+1,nlonp4+2 are not ! necessary. Therefore, tasks with mytidi==0 send/recv with dummy iprev ! tasks, and tasks with mytidi==ntaski-1 send/recv with dummy inext tasks. ! (dummy tasks have mytid==MPI_PROC_NULL, so comm does not take place). ! This routine is called after mp_bndlats, so longitude data passed includes ! boundary latitudes. ! ! Args: integer,intent(in) :: ixt,mxf type(fields_4d),intent(inout) :: f(mxf) ! assume 4d data in f(n)%data ! ! Local: integer :: n,nn,nlats,ier,len,inext,iprev,nflds,isend0,isend1, | irecv0,irecv1,lendat real,allocatable :: | sndbuf0(:,:,:,:), ! send buffer for lon0 ,lon0+1 (k,2,j,nf) | sndbuf1(:,:,:,:), ! send buffer for lon1-1,lon1 (k,2,j,nf) | rcvbuf0(:,:,:,:), ! recv buffer for lon0-2,lon0-1 (k,2,j,nf) | rcvbuf1(:,:,:,:) ! recv buffer for lon1+1,lon1+2 (k,2,j,nf) real :: fmin,fmax #ifdef VT ! call vtsymdef(101, 'mp_bndlons','Communication',ier) call vtbegin(101,ier) #endif if (do_rtc_mpi) call timer(rtc0_bndlons,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): nlats = (lat1+2)-(lat0-2)+1 nflds = 0 do n=1,mxf if (f(n)%mpi) nflds = nflds+1 enddo if (nflds==0) then write(6,"('>>> WARNING mp_bndlons: no f(:)%mpi are true --', | ' returning.')") return endif allocate(sndbuf0(nlevp1,2,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons: error allocating sndbuf0.')") allocate(sndbuf1(nlevp1,2,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons: error allocating sndbuf1.')") allocate(rcvbuf0(nlevp1,2,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons: error allocating rcvbuf0.')") allocate(rcvbuf1(nlevp1,2,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons: error allocating rcvbuf1.')") len = 2*nlevp1*nlats*nflds lendat = 2*nlevp1*nlats ! ! Locate adjacent tasks (includes null tasks on either side): iprev = itask_table(mytidi-1,mytidj) ! task to left (west) inext = itask_table(mytidi+1,mytidj) ! task to right (east) ! ! Load sndbuf0 with lon0,lon0+1 and sndbuf1 with lon1-1,lon1: nn = 0 do n=1,mxf if (f(n)%mpi) then nn = nn+1 sndbuf0(:,:,:,nn) = f(n)%data(:,lon0:lon0+1,lat0-2:lat1+2,ixt) sndbuf1(:,:,:,nn) = f(n)%data(:,lon1-1:lon1,lat0-2:lat1+2,ixt) ! call fminmax(sndbuf0(:,:,:,nn),lendat,fmin,fmax) ! write(6,"('bndlons: sndbuf0 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax ! call fminmax(sndbuf1(:,:,:,nn),lendat,fmin,fmax) ! write(6,"('bndlons: sndbuf1 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif enddo ! ! Send lon0:lon0+1 (sndbuf0) to iprev: call mpi_isend(sndbuf0,len,MPI_REAL8,iprev,1,MPI_COMM_WORLD, | isend0,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons send0 to iprev') ! ! Send lon1-1:lon1 (sndbuf1) to inext: call mpi_isend(sndbuf1,len,MPI_REAL8,inext,1,MPI_COMM_WORLD, | isend1,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons send1 to inext') ! ! Receive lon0-2:lon0-1 (rcvbuf0) from iprev: call mpi_irecv(rcvbuf0,len,MPI_REAL8,iprev,1,MPI_COMM_WORLD, | irecv0,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons recv0 fm iprev') ! ! Receive lon1+1:lon1+2 (rcvbuf1) from inext: call mpi_irecv(rcvbuf1,len,MPI_REAL8,inext,1,MPI_COMM_WORLD, | irecv1,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons recv1 fm inext') ! ! Wait for completions: call mpi_wait(isend0,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons wait for send0') call mpi_wait(isend1,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons wait for send1') call mpi_wait(irecv0,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons wait for recv0') call mpi_wait(irecv1,irstat,ier) if (ier /= 0) call handle_mpi_err(ier,'mp_bndlons wait for recv1') ! ! Copy lon0-2:lon0-1 from rcvbuf0, and lon1+1:lon1+2 from rcvbuf1: nn = 0 do n=1,mxf if (f(n)%mpi) then nn = nn+1 if (lon0 /= 1) then f(n)%data(:,lon0-2:lon0-1,lat0-2:lat1+2,ixt) = | rcvbuf0(:,:,:,nn) ! call fminmax(f(n)%data(:,lon0-2:lon0-1,lat0-2:lat1+2,ixt), ! | lendat,fmin,fmax) ! write(6,"('bndlons: rcvbuf0 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif if (lon1 /= nlonp4) then f(n)%data(:,lon1+1:lon1+2,lat0-2:lat1+2,ixt) = | rcvbuf1(:,:,:,nn) ! call fminmax(f(n)%data(:,lon1+1:lon1+2,lat0-2:lat1+2,ixt), ! | lendat,fmin,fmax) ! write(6,"('bndlons: rcvbuf1 field ',a,' min,max=',2e12.4)") ! | f(n)%short_name(1:8),fmin,fmax endif endif enddo ! ! Release local buffer space: deallocate(sndbuf0) deallocate(sndbuf1) deallocate(rcvbuf0) deallocate(rcvbuf1) ! if (do_rtc_mpi) then call timer(rtc0_bndlons,tsec,'end') rtcmp_bndlons = rtcmp_bndlons+tsec endif #ifdef VT ! call vtsymdef(101, 'mp_bndlons','Communication',ier) call vtend(101,ier) #endif end subroutine mp_bndlons !----------------------------------------------------------------------- subroutine mp_bndlons_f3d(f,id1,i0,i1,j0,j1,nf) ! ! ! Exchange boundary longitude data of 3-d fields between tasks. ! Each task sends its i0,i0+1 data to task iprev, and its i1-1,i1 ! data to inext. ! Each task receives its i0-2,i0-1 data from task iprev, and its ! i1+1,i1+2 data from task inext. ! Because of periodic points, lons -1,0 and nlonp4+1,nlonp4+2 are not ! necessary. Therefore, tasks with mytidi==0 send/recv with dummy iprev ! tasks, and tasks with mytidi==ntaski-1 send/recv with dummy inext tasks. ! (dummy tasks have mytid==MPI_PROC_NULL, so comm does not take place). ! Note that f must be dimensioned (id1,i0-2:i1+2,j0:j1). ! ! E.g., as called from minor.F: ! real,dimension(lev0:lev1,lon0-2:lon1+2,lat0:lat1) :: ! | ftm1_jdif ! lat diffs (includes lon boundaries) (s8) ! call mp_bndlons_f3d(ftm1_jdif,nlevs,lon0,lon1,lat0-2,lat1+2,1) ! ! Args: integer,intent(in) :: id1,i0,i1,j0,j1,nf real,intent(inout) :: f(id1,i0-2:i1+2,j0:j1,nf) ! lons include boundaries ! ! Local: integer :: n,ier,len,inext,iprev,isend0,isend1,nlats,j, | irecv0,irecv1,lendat real,allocatable :: | sndbuf0(:,:,:,:), ! send buffer for i0 ,i0+1 (id1,2,j0:j1,nf) | sndbuf1(:,:,:,:), ! send buffer for i1-1,i1 (id1,2,j0:j1,nf) | rcvbuf0(:,:,:,:), ! recv buffer for i0-2,i0-1 (id1,2,j0:j1,nf) | rcvbuf1(:,:,:,:) ! recv buffer for i1+1,i1+2 (id1,2,j0:j1,nf) real :: fmin,fmax #ifdef VT ! call vtsymdef(102, 'mp_bndlons_f3d','Communication',ier) call vtbegin(102,ier) #endif if (do_rtc_mpi) call timer(rtc0_bndlons_f3d,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): allocate(sndbuf0(id1,2,j0:j1,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons_f3d: error allocating sndbuf0.')") allocate(sndbuf1(id1,2,j0:j1,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons_f3d: error allocating sndbuf1.')") allocate(rcvbuf0(id1,2,j0:j1,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons_f3d: error allocating rcvbuf0.')") allocate(rcvbuf1(id1,2,j0:j1,nf),stat=ier) if (ier /= 0) | write(6,"('>>> mp_bndlons_f3d: error allocating rcvbuf1.')") nlats = j1-j0+1 len = id1*2*nlats*nf lendat = id1*2*nlats ! ! Locate adjacent tasks (includes null tasks on either side): iprev = itask_table(mytidi-1,mytidj) ! task to left (west) inext = itask_table(mytidi+1,mytidj) ! task to right (east) ! ! Load sndbuf0 with i0,i0+1 and sndbuf1 with i1-1,i1: do n=1,nf do j=j0,j1 sndbuf0(:,:,j,n) = f(:,i0:i0+1,j,n) sndbuf1(:,:,j,n) = f(:,i1-1:i1,j,n) enddo ! call fminmax(sndbuf0(:,:,:,n),lendat,fmin,fmax) ! write(6,"('bndlons_f3d: sndbuf0 field ',i2,' min,max=',2e12.4)") ! | n,fmin,fmax ! call fminmax(sndbuf1(:,:,:,n),lendat,fmin,fmax) ! write(6,"('bndlons_f3d: sndbuf1 field ',i2,' min,max=',2e12.4)") ! | n,fmin,fmax enddo ! ! Send i0:i0+1 (sndbuf0) to task iprev: call mpi_isend(sndbuf0,len,MPI_REAL8,iprev,1,MPI_COMM_WORLD, | isend0,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d send0 to iprev') ! ! Send i1-1:i1 (sndbuf1) to task inext: call mpi_isend(sndbuf1,len,MPI_REAL8,inext,1,MPI_COMM_WORLD, | isend1,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d send1 to inext') ! ! Receive i0-2:i0-1 (rcvbuf0) from task iprev: call mpi_irecv(rcvbuf0,len,MPI_REAL8,iprev,1,MPI_COMM_WORLD, | irecv0,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d recv0 fm iprev') ! ! Receive i1+1:i1+2 (rcvbuf1) from task inext: call mpi_irecv(rcvbuf1,len,MPI_REAL8,inext,1,MPI_COMM_WORLD, | irecv1,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d recv1 fm inext') ! ! Wait for completions: call mpi_wait(isend0,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d wait for send0') call mpi_wait(isend1,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d wait for send1') call mpi_wait(irecv0,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d wait for recv0') call mpi_wait(irecv1,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_bndlons_f3d wait for recv1') ! ! Copy i0-2:i0-1 from rcvbuf0, and i1+1:i1+2 from rcvbuf1: do n=1,nf if (i0 /= 1) then do j=j0,j1 f(:,i0-2:i0-1,j,n) = rcvbuf0(:,:,j,n) enddo ! call fminmax(f(:,i0-2:i0-1,:,n),lendat,fmin,fmax) ! write(6,"('bndlons_f3d: rcvbuf0 field ',i2,' min,max=', ! | 2e12.4)") n,fmin,fmax endif if (i1 /= nlonp4) then do j=j0,j1 f(:,i1+1:i1+2,j,n) = rcvbuf1(:,:,j,n) enddo ! call fminmax(f(:,i1+1:i1+2,:,n),lendat,fmin,fmax) ! write(6,"('bndlons_f3d: rcvbuf1 field ',i2,' min,max=', ! | 2e12.4)") n,fmin,fmax endif enddo ! ! Release local buffer space: deallocate(sndbuf0) deallocate(sndbuf1) deallocate(rcvbuf0) deallocate(rcvbuf1) ! if (do_rtc_mpi) then call timer(rtc0_bndlons_f3d,tsec,'end') rtcmp_bndlons_f3d = rtcmp_bndlons_f3d+tsec endif #ifdef VT ! call vtsymdef(102, 'mp_bndlons_f3d','Communication',ier) call vtend(102,ier) #endif end subroutine mp_bndlons_f3d !----------------------------------------------------------------------- subroutine mp_polelats(ixt) ! ! Make latitudes j=-1,0 from j=2,1, and j=nlat+1,nlat+2 from nlat-1,nlat ! Longitude data are swapped across the poles, with a sign change if ! necessary (i.e., U or V). ! 3/02: this is an attempt to replace mp_pole_lats with a faster algorithm. ! ! Args: integer,intent(in) :: ixt ! ! Local: integer :: i,ii,j0,j1,if,it,iit,i0,i1,itask,ier,lenrecv,lensend, | nlonhalf, | irecv(ntask), itrecv, | isend(ntask), itsend, | ntrecv, ! number of tasks from which to receive needlons | ntsend ! number of tasks to which to send havelons integer :: | newlons(nlonp4), ! longitudes needed across the pole | lonseast(nlonp4),lonswest(nlonp4), | needlons(nlonp4,0:ntask-1), ! longitudes needed by each task | irecvlons(nlonp4), | isendto(2,0:ntask-1), ! i0,i1 and tasks to send my lons to | irecvfm(2,0:ntask-1) ! i0,i1 and tasks to recv my needlons from real,allocatable :: | rcvbuf(:,:,:,:,:), ! recv for new lats on this task (k,ineed,2,nf,nt) | sndbuf(:,:,:,:,:) ! send for new lats on remote task (k,ihave,2,nf,nt) real :: fmin,fmax,signchange ! #ifdef MPI ! ! Serial run of an MPI job (1 task): if (ntask==1) then call mk_polelat( 0,1,ixt) call mk_polelat(-1,2,ixt) call mk_polelat(nlat+1,nlat ,ixt) call mk_polelat(nlat+2,nlat-1,ixt) return endif ! ntask==1 #else ! ! Serial job (non-MPI): call mk_polelat( 0,1,ixt) call mk_polelat(-1,2,ixt) call mk_polelat(nlat+1,nlat ,ixt) call mk_polelat(nlat+2,nlat-1,ixt) return #endif ! if (mytidj /= 0 .and. mytidj /= ntaskj-1) return ! #ifdef VT ! call vtsymdef(103, 'mp_polelat','Communication',ier) call vtbegin(103,ier) #endif ! ! Determine longitudes at which east and west hemispheres are exchanged. ! Data at newlons(i) are replaced by data at lonswest(i) for west hemisphere, ! or lonseast(i) for east hemisphere. ! When nlonp4==76, newlons(:) will be 37-74 and 3-40, i.e., ! (1-38) <- (37-74) and (39-76) <- (3-40) ! Another way of looking at it: ! newlons(1) -> [east,west]lons ! 37-74 -> 1-38 west ! 3-40 -> 39-76 east ! nlonhalf = nlonp4/2 do i=1,nlonhalf newlons(i) = nlonhalf+i-2 lonswest(newlons(i)) = i enddo do i=nlonhalf+1,nlonp4 newlons(i) = 2+i-nlonhalf lonseast(newlons(i)) = i enddo ! write(6,"(/,'newlons(:) = ',/,(15i4))") newlons(:) ! write(6,"('lonswest(:) = ',/,(15i4))") lonswest(:) ! write(6,"('lonseast(:) = ',/,(15i4))") lonseast(:) ! ! Determine which longitudes each task needs to make new polar boundary ! latitudes (i.e., across the pole from its own longitudes): ! needlons(:,:) = 0 do it=0,ntask-1 i0 = tasks(it)%lon0 i1 = tasks(it)%lon1 do i=i0,i1 needlons(i,it) = newlons(i) enddo ! write(6,"('task ',i2,' needlons=',/,(10i4))") it,needlons(:,it) enddo ! write(6,"(/,'My needlons = ',/,(10i4))") needlons(:,mytid) ! irecvfm(1,:) = 9999 irecvfm(2,:) = -1 isendto(1,:) = 9999 isendto(2,:) = -1 do i=0,ntaski-1 ! loop over tasks in my latitude row in the task table itask = tasks(itask_table(i,mytidj))%mytid i0 = tasks(itask)%lon0 i1 = tasks(itask)%lon1 ! if (itask /= mytid) then ! current task is not me ! ! Determine tasks I need to receive my needlons from: ! (1st dimension of irecvfm is 2, for lon0,lon1 to receive) do ii=1,nlonp4 if (needlons(ii,mytid) > 0) then ! I need this lon if (needlons(ii,mytid) >= i0 .and. | needlons(ii,mytid) <= i1) then if (needlons(ii,mytid) < irecvfm(1,itask)) | irecvfm(1,itask) = needlons(ii,mytid) if (needlons(ii,mytid) > irecvfm(2,itask)) | irecvfm(2,itask) = needlons(ii,mytid) endif endif enddo ! ! Determine tasks I need to send my longitudes to: ! (1st dimension of isendto is 2, for lon0,lon1 to send) do ii=1,nlonp4 if (needlons(ii,itask) >= lon0 .and. | needlons(ii,itask) <= lon1) then ! itask needs this lon from me if (needlons(ii,itask) < isendto(1,itask)) | isendto(1,itask) = needlons(ii,itask) if (needlons(ii,itask) > isendto(2,itask)) | isendto(2,itask) = needlons(ii,itask) endif enddo ! ii=1,nlonp4 ! endif ! current task is not me enddo ! i=0,ntaski-1 where(irecvfm==9999) irecvfm = -1 where(isendto==9999) isendto = -1 ! do i=0,ntask-1 ! if (irecvfm(1,i) /= -1 .or. irecvfm(2,i) /= -1) ! | write(6,"('Will receive i0,i1=',2i3,' from task ',i2)") ! | irecvfm(:,i),i ! enddo ! do i=0,ntask-1 ! if (isendto(1,i) /= -1 .or. isendto(2,i) /= -1) ! | write(6,"('Will send i0,i1=',2i3,' to task ',i2)") ! | isendto(:,i),i ! enddo ! ! Determine how many tasks will be sent to and received from: ! ntrecv = 0 ; ntsend = 0 do it=0,ntask-1 if (irecvfm(1,it) > -1 .and. irecvfm(2,it) > -1) then ntrecv = ntrecv+1 endif if (isendto(1,it) > -1 .and. isendto(2,it) > -1) then ntsend = ntsend+1 endif enddo ! it=1,ntask-1 ! ! Allocate send buffer. ! sndbuf(:,:,:,:,:), ! send for new lats on remote task (k,i,2,nf,ntsend) ! allocate(sndbuf(nlevp1,mxlon,2,nf4d,ntsend),stat=ier) if (ier /= 0) then write(6,"('>>> mp_polelats: error allocating sndbuf: ', | ' mxlon=',i3,' ntsend=',i3)") mxlon,ntsend else ! write(6,"('mp_polelats allocated sndbuf: mxlon=',i3, ! | ' ntsend=',i3)") mxlon,ntsend endif lensend = nlevp1*mxlon*2*nf4d ! ! Allocate receive buffer. ! rcvbuf(:,:,:,:,:), ! recv for new lats on this task (k,i,2,nf,ntrecv) ! allocate(rcvbuf(nlevp1,mxlon,2,nf4d,ntrecv),stat=ier) if (ier /= 0) then write(6,"('>>> mp_polelats: error allocating rcvbuf: ', | ' mxlon=',i3,' ntrecv=',i3)") mxlon,ntrecv else ! write(6,"('mp_polelats allocated rcvbuf: mxlon=',i3, ! | ' ntrecv=',i3)") mxlon,ntrecv endif lenrecv = nlevp1*mxlon*2*nf4d ! ! Load send buffer: j0 = 1 ; j1 = 2 ! Make shem lats 0,-1 from 1,2 if (mytidj == ntaskj-1) then ! Make nhem lats nlat+1,nlat+2 from nlat-1,nlat j0 = nlat-1 ; j1 = nlat endif iit = 0 do it=0,ntask-1 if (isendto(1,it)/=-1.and.isendto(2,it)/=-1) then iit = iit+1 do if=1,nf4d ii = 0 do i=isendto(1,it),isendto(2,it) ii = ii+1 sndbuf(:,ii,1:2,if,iit) = f4d(if)%data(:,i,j0:j1,ixt) ! write(6,"('it=',i3,' if=',i3,' i=',i3,' sndbuf1=',/, ! | (6e12.4))") it,if,i, sndbuf(:,ii,1,if,iit) enddo enddo ! if=1,nf4d endif ! isendto /= -1 enddo ! it=1,ntaski-1 ! ! Post sends of longitudes I have that are needed on other tasks: ! itrecv = 0 itsend = 0 iit = 0 do it=0,ntask-1 if (isendto(1,it)/=-1.and.isendto(2,it)/=-1) then iit = iit+1 itsend = itsend+1 call mpi_isend(sndbuf(1,1,1,1,iit),lensend,MPI_REAL8,it,1, | MPI_COMM_WORLD,isend(iit),ier) if (ier /= 0) call handle_mpi_err(ier,'mp_polelats send') ! write(6,"('Posted send of lons ',i3,'-',i3,' to task ',i3, ! | ' iit=',i2,' lensend=',i5)") isendto(1:2,it),it,iit,lensend endif enddo ! ! Post receives of longitudes I need: ! iit = 0 do it=0,ntask-1 if (irecvfm(1,it)/=-1.and.irecvfm(2,it)/=-1) then iit = iit+1 call mpi_irecv(rcvbuf(1,1,1,1,iit),lenrecv,MPI_REAL8,it,1, | MPI_COMM_WORLD,irecv(iit),ier) if (ier /= 0) call handle_mpi_err(ier,'mp_polelats recv') ! write(6,"('Posted recv of lons ',i3,'-',i3,' fm task ',i3, ! | ' iit=',i2,' lenrecv=',i5)") irecvfm(1:2,it),it,iit,lenrecv endif enddo ! ! Wait for completion of sends: do it=1,ntsend call mpi_wait(isend(it),irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_polelats wait for send') ! write(6,"('Completed wait for send: it=',i2)") it enddo ! ! Wait for completion of receives: do it=1,ntrecv call mpi_wait(irecv(it),irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_polelats wait for recv') ! write(6,"('Completed wait for recv: it=',i2)") it enddo ! ! Define f4d at new latitudes from recvbuf: ! j0 = -1 ; j1 = 0 ! Receive data for new S lats 0,-1 if (mytidj == ntaskj-1) then ! Receive data for new N lats nlat+1,nlat+2 j0 = nlat+1 ; j1 = nlat+2 endif iit = 0 do it=0,ntask-1 if (irecvfm(1,it)/=-1.and.irecvfm(2,it)/=-1) then iit = iit+1 field_loop: do if=1,nf4d if (f4d(if)%polesign==0.) cycle field_loop ! n2d,ne,o2p ii = 0 do i=irecvfm(1,it),irecvfm(2,it) ! longitudes that were sent ii = ii+1 ! ! Determine if lon to be replaced is east or west: if (lon1 <= nlonhalf) then irecvlons(ii) = lonswest(i) elseif (lon0 > nlonhalf) then irecvlons(ii) = lonseast(i) else ! task is split between east and west irecvlons(ii) = lonswest(i) if (i < nlonhalf) irecvlons(ii) = lonseast(i) endif ! ! polesign == -1. for u,v velocities (is +1. for all other fields): f4d(if)%data(:,irecvlons(ii),j0,ixt)= | rcvbuf(:,ii,2,if,iit)*f4d(if)%polesign f4d(if)%data(:,irecvlons(ii),j1,ixt)= | rcvbuf(:,ii,1,if,iit)*f4d(if)%polesign enddo enddo field_loop endif enddo ! ! Release local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! #ifdef VT ! call vtsymdef(103, 'mp_polelat','Communication',ier) call vtend(103,ier) #endif end subroutine mp_polelats !----------------------------------------------------------------------- subroutine mp_gatherlons(f,mxf,ixt) ! ! Gather longitude data in a row of tasks to leftmost task in the row. ! I.e., task with mytidi,j==(0,mytidj) receives from tasks with ! mytidi,j==(i,mytidj) where i=1,ntaski-1. ! Pass data only for fields with %mpi==.true. ! This is called before fft calls in filter/smoothing routines. ! ! Args: integer,intent(in) :: ixt,mxf type(fields_4d),intent(inout) :: f(mxf) ! assume 4d data in f(n)%data ! ! Local: integer :: i,j,k,n,nn,nlats,nlons,nflds,len,idest,isrc,ier,isend, | irecv,itask,lonrecv0,lonrecv1,mtag real :: fmin,fmax real,allocatable :: | sndbuf(:,:,:,:), ! send buffer (nlevp1,mxlon,lat0:lat1,nflds) | rcvbuf(:,:,:,:) ! recv buffer (nlevp1,mxlon,lat0:lat1,nflds) ! ! This is unnecessary if there is only 1 column of tasks: if (ntaski==1) then write(6,"('mp_gatherlons returning because ntaski==',i2)") | ntaski return endif #ifdef VT ! call vtsymdef(104, 'mp_gatherlons','Communication',ier) call vtbegin(104,ier) #endif if (do_rtc_mpi) call timer(rtc0_gatherlons,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): nlats = lat1-lat0+1 nlons = lon1-lon0+1 nflds = 0 do n=1,mxf if (f(n)%mpi) nflds = nflds+1 enddo if (nflds==0) then write(6,"('>>> WARNING mp_gatherlons: no f(:)%mpi are true --', | ' returning.')") return endif allocate(sndbuf(nlevp1,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gatherlons: error allocating sndbuf.')") allocate(rcvbuf(nlevp1,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gatherlons: error allocating rcvbuf.')") len = mxlon*nlevp1*nlats*nflds ! ! If mytidi==0, receive from other tasks in my row (mytidi>0,mytidj): if (mytidi == 0) then do itask=1,ntaski-1 isrc = itask_table(itask,mytidj) mtag = isrc+mytid call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,mtag,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons recv fm isrc') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons wait for recv0') ! ! Copy data from receive buffer: lonrecv0 = tasks(isrc)%lon0 lonrecv1 = tasks(isrc)%lon1 nn = 0 do n=1,mxf if (f(n)%mpi) then nn=nn+1 f(n)%data(:,lonrecv0:lonrecv1,lat0:lat1,ixt) = | rcvbuf(:,:,:,nn) ! call fminmax(f(n)%data(:,lonrecv0:lonrecv1,lat0:lat1,ixt), ! | nlevp1*(lonrecv1-lonrecv0+1)*nlats,fmin,fmax) ! write(6,"('gatherlons recv from task ',i2,': field ',a, ! | ' lonrecv0,1=',2i3,' min,max=',2e12.4)") ! | isrc,f(n)%short_name(1:8),lonrecv0,lonrecv1,fmin,fmax endif enddo enddo ! ! If mytidi > 0, load send buffer, and send to task (0,mytidj): else ! mytidi==0 idest = itask_table(0,mytidj) nn = 0 do n=1,mxf if (f(n)%mpi) then nn=nn+1 sndbuf(:,1:nlons,:,nn) = f(n)%data(:,lon0:lon1,lat0:lat1, | ixt) ! call fminmax(sndbuf(1:nlevp1,1:nlons,1:nlats,nn), ! | nlons*nlevp1*nlats,fmin,fmax) ! write(6,"('gatherlons send to task ',i2,': field ',a, ! | ' min,max=',2e12.4)") idest,f(n)%short_name(1:8),fmin,fmax endif enddo mtag = idest+mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,mtag,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons send0 to idest') call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons wait for send0') endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_gatherlons,tsec,'end') rtcmp_gatherlons = rtcmp_gatherlons+tsec endif #ifdef VT ! call vtsymdef(104, 'mp_gatherlons','Communication',ier) call vtend(104,ier) #endif end subroutine mp_gatherlons !----------------------------------------------------------------------- subroutine mp_scatterlons(f,mxf,ixt) ! ! Args: integer,intent(in) :: ixt,mxf type(fields_4d),intent(inout) :: f(mxf) ! assume 4d data in f(n)%data ! ! Local: integer :: i,j,k,n,nn,nlats,nlons,nflds,len,idest,isrc,ier,isend, | irecv,itask,lonsend0,lonsend1,mtag real :: fmin,fmax real,allocatable :: | sndbuf(:,:,:,:), ! send buffer (nlevp1,mxlon,lat0:lat1,nflds) | rcvbuf(:,:,:,:) ! recv buffer (nlevp1,mxlon,lat0:lat1,nflds) ! ! This is unnecessary if there is only 1 column of tasks: if (ntaski==1) then write(6,"('mp_scatterlons returning because ntaski==',i2)") | ntaski return endif #ifdef VT ! call vtsymdef(105, 'mp_scatterlons','Communication',ier) call vtbegin(105,ier) #endif if (do_rtc_mpi) call timer(rtc0_scatterlons,tsec,'begin') ! ! Allocate send and receive buffers (only fields with %mpi==true): nlats = lat1-lat0+1 nflds = 0 do n=1,mxf if (f(n)%mpi) nflds = nflds+1 enddo if (nflds==0) then write(6,"('>>> WARNING mp_scatterlons: no f(:)%mpi are true --', | ' returning.')") return endif allocate(sndbuf(nlevp1,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_scatterlons: error allocating sndbuf.')") allocate(rcvbuf(nlevp1,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_scatterlons: error allocating rcvbuf.')") len = mxlon*nlevp1*nlats*nflds ! ! If mytidi==0, send to other tasks in my row (mytidi>0,mytidj): if (mytidi == 0) then do itask=1,ntaski-1 idest = itask_table(itask,mytidj) lonsend0 = tasks(idest)%lon0 lonsend1 = tasks(idest)%lon1 nlons = lonsend1-lonsend0+1 mtag = idest+mytid nn = 0 do n=1,mxf if (f(n)%mpi) then nn=nn+1 sndbuf(:,1:nlons,:,nn) = f(n)%data(:,lonsend0:lonsend1, | lat0:lat1,ixt) endif enddo mtag = idest+mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,mtag,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons send to idest') call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons wait for send') enddo ! ! If mytidi > 0, receive from task (0,mytidj): else isrc = itask_table(0,mytidj) mtag = isrc+mytid call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,mtag,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons recv fm isrc') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons wait for recv') nlons = lon1-lon0+1 nn = 0 do n=1,mxf if (f(n)%mpi) then nn=nn+1 f(n)%data(:,lon0:lon1,lat0:lat1,ixt) = | rcvbuf(:,1:nlons,:,nn) endif enddo endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_scatterlons,tsec,'end') rtcmp_scatterlons = rtcmp_scatterlons+tsec endif #ifdef VT ! call vtsymdef(105, 'mp_scatterlons','Communication',ier) call vtend(105,ier) #endif end subroutine mp_scatterlons !----------------------------------------------------------------------- subroutine mp_gatherlons_f3d(f,k0,k1,i0,i1,j0,j1,nflds) ! ! Gather longitude data in a row of tasks to leftmost task in the row. ! On entry f(k0:k1,i0:i1,j0:j1,nflds) is defined for current task. ! On exit f(k0:k1,nlonp4,j0:j1,nflds) is defined for task with mytidi==0. ! ! Args: integer,intent(in) :: k0,k1,i0,i1,j0,j1,nflds real,intent(inout) :: f(k0:k1,nlonp4,j0:j1,nflds) ! ! Local: integer :: i,k,j,n,nlons,nlats,nlonrecv,nlevs,len,idest,isrc,ier, | isend,irecv,itask,lonrecv0,lonrecv1,mtag real :: fmin,fmax real,allocatable :: | sndbuf(:,:,:,:), ! send buffer (nlevs,mxlon,nlats,nflds) | rcvbuf(:,:,:,:) ! recv buffer (nlevs,mxlon,nlats,nflds) #ifdef VT ! call vtsymdef(106, 'mp_gatherlons_f3d','Communication',ier) call vtbegin(106,ier) #endif if (do_rtc_mpi) call timer(rtc0_gatherlons_f3d,tsec,'begin') ! ! Allocate send and receive buffers: nlons = i1-i0+1 nlevs = k1-k0+1 nlats = j1-j0+1 if (nflds==0) then write(6,"('>>> WARNING mp_gatherlons_f3d: no fields? nflds=',i2)") | ' -- returning.')") nflds return endif allocate(sndbuf(nlevs,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gatherlons_f3d: error allocating sndbuf.')") allocate(rcvbuf(nlevs,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_gatherlons_f3d: error allocating rcvbuf.')") len = nlevs*mxlon*nlats*nflds ! ! If mytidi==0, receive from other tasks in my row (mytidi>0,mytidj): if (mytidi == 0) then do itask=1,ntaski-1 isrc = itask_table(itask,mytidj) mtag = isrc+mytid call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,mtag,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons_f3d recv fm isrc') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons_f3d wait for recv0') ! ! Copy data from receive buffer: lonrecv0 = tasks(isrc)%lon0 lonrecv1 = tasks(isrc)%lon1 nlonrecv = lonrecv1-lonrecv0+1 do n=1,nflds do j=j0,j1 f(:,lonrecv0:lonrecv1,j,n) = rcvbuf(:,1:nlonrecv,j-j0+1,n) enddo ! j=j0,j1 enddo ! n=1,nflds enddo ! itask=1,ntaski-1 ! ! If mytidi > 0, load send buffer, and send to task (0,mytidj): else ! mytidi /= 0 idest = itask_table(0,mytidj) do n=1,nflds do j=j0,j1 sndbuf(:,1:nlons,j-j0+1,n) = f(:,i0:i1,j,n) enddo ! j=j0,j1 enddo ! n=1,nflds mtag = idest+mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,mtag,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons_f3d send0 to idest') call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_gatherlons_f3d wait for send0') endif ! mytidi==0 ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_gatherlons_f3d,tsec,'end') rtcmp_gatherlons_f3d = rtcmp_gatherlons_f3d+tsec endif #ifdef VT ! call vtsymdef(106, 'mp_gatherlons_f3d','Communication',ier) call vtend(106,ier) #endif end subroutine mp_gatherlons_f3d !----------------------------------------------------------------------- subroutine mp_scatterlons_f3d(f,k0,k1,i0,i1,j0,j1,nflds) ! ! Redistribute longitudes from left most task in j-row to other tasks ! in the row. ! On input, f(:,nlonp4,j0:j1,nflds) is defined for tasks with mytidi==0. ! On output, f(:,i0:i1,j0:j1,nflds) is defined for all tasks. ! ! Args: integer,intent(in) :: k0,k1,i0,i1,j0,j1,nflds real,intent(inout) :: f(k0:k1,nlonp4,j0:j1,nflds) ! ! Local: integer :: i,k,j,n,nlevs,nlons,nlats,nlonsend,len,idest,isrc,ier, | isend,irecv,itask,lonsend0,lonsend1,mtag real :: fmin,fmax real,allocatable :: | sndbuf(:,:,:,:), ! send buffer (nlevs,mxlon,nlats,nflds) | rcvbuf(:,:,:,:) ! recv buffer (nlevs,mxlon,nlats,nflds) #ifdef VT ! call vtsymdef(107, 'mp_scatterlons_f3d','Communication',ier) call vtbegin(107,ier) #endif if (do_rtc_mpi) call timer(rtc0_scatterlons_f3d,tsec,'begin') ! ! Allocate send and receive buffers: nlons = i1-i0+1 nlevs = k1-k0+1 nlats = j1-j0+1 if (nflds==0) then write(6,"('>>> WARNING mp_scatterlons_f3d: no fields? nflds=', | i3,' returning.')") nflds return endif allocate(sndbuf(nlevs,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_scatterlons_f3d: error allocating sndbuf.')") allocate(rcvbuf(nlevs,mxlon,nlats,nflds),stat=ier) if (ier /= 0) | write(6,"('>>> mp_scatterlons_f3d: error allocating rcvbuf.')") len = nlevs*mxlon*nlats*nflds ! ! If mytidi==0, send to other tasks in my row (mytidi>0,mytidj): if (mytidi == 0) then do itask=1,ntaski-1 idest = itask_table(itask,mytidj) lonsend0 = tasks(idest)%lon0 lonsend1 = tasks(idest)%lon1 nlonsend = lonsend1-lonsend0+1 mtag = idest+mytid do n=1,nflds do j=j0,j1 sndbuf(:,1:nlonsend,j-j0+1,n) = f(:,lonsend0:lonsend1,j,n) enddo ! j=j0,j1 enddo ! n=1,nflds mtag = idest+mytid call mpi_isend(sndbuf,len,MPI_REAL8,idest,mtag,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons_f3d send to idest') call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons_f3d wait for send') enddo ! itask=1,ntaski-1 ! ! If mytidi > 0, receive from task (0,mytidj): else isrc = itask_table(0,mytidj) mtag = isrc+mytid call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,mtag,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons_f3d recv fm isrc') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_scatterlons_f3d wait for recv') do n=1,nflds do j=j0,j1 f(:,i0:i1,j,n) = rcvbuf(:,1:nlons,j-j0+1,n) enddo ! j=j0,j1 enddo ! n=1,nflds endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_scatterlons_f3d,tsec,'end') rtcmp_scatterlons_f3d = rtcmp_scatterlons_f3d+tsec endif #ifdef VT ! call vtsymdef(107, 'mp_scatterlons_f3d','Communication',ier) call vtend(107,ier) #endif end subroutine mp_scatterlons_f3d !----------------------------------------------------------------------- subroutine mp_periodic_f4d(ixt) use fields_module,only: i_tn ! for debug ! ! Define periodic points for all fields f4d(nf4d_hist) ! (all latitudes and vertical column). This is called after ! reading source history data. ! Periodic points: ! lons 1,2 <- nlonp4-3,nlonp4-2 and nlonp4-1,nlonp4 <- 3,4 ! ! Args: integer,intent(in) :: ixt ! ! Local: integer :: idest,isrc,isend,irecv,ier,i,j,jj,n,len,k,nlats,mtag, | status(MPI_STATUS_SIZE) real,allocatable :: sndbuf(:,:,:,:) ! (nlevp1,nlats,nf4d_hist,2) real,allocatable :: rcvbuf(:,:,:,:) ! (nlevp1,nlats,nf4d_hist,2) ! ! Use assignment and return in the special case of a serial run: if (ntask == 1) then ! lon0,lon1 == 1,nlonp4 do n=1,nf4d_hist ! loop for fields on history at time ixt do j=lat0-2,lat1+2 ! latitude f4d(n)%data(:,lon0:lon0+1,j,ixt) = ! e.g.: 1,2 <= 73,74 | f4d(n)%data(:,nlon+1:nlon+2,j,ixt) f4d(n)%data(:,lon1-1:lon1,j,ixt) = ! e.g.: 75,76 <= 3,4 | f4d(n)%data(:,lon0+2:lon0+3,j,ixt) enddo enddo return endif ! ! The restriction that every task must carry at least 4 longitudes ! means that tasks with mytidi==0 will have lons 1->4 and tasks ! with mytidi==ntaski-1 will have lons nlonp4-3->nlonp4. ! if (mytidi /= 0 .and. mytidi /= ntaski-1) return #ifdef VT ! call vtsymdef(108, 'mp_periodic_f4d','Communication',ier) call vtbegin(108,ier) #endif if (do_rtc_mpi) call timer(rtc0_periodic_f4d,tsec,'begin') ! ! Allocate send and receive buffers: nlats = mxlat+4 ! +4 is to cover lat0-1,lat0-2,lat1+1,lat1+2 allocate(sndbuf(nlevp1,nlats,nf4d_hist,2),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f4d: error allocating sndbuf:', | ' nlevp1=',i3,' nlats=',i3,' nf4d_hist=',i3,' ier=',i4)") | nlevp1,nlats,nf4d_hist,ier ! allocate(rcvbuf(nlevp1,nlats,nf4d_hist,2),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f4d: error allocating rcvbuf:', | ' nlevp1=',i3,' nlats=',i3,' nf4d_hist=',i3,' ier=',i4)") | nlevp1,nlats,nf4d_hist,ier len = nlevp1*nlats*nf4d_hist*2 ! ! If I am at west end (mytidi==0) of task row, send lons 3,4 to task ! on east end (mytidi==ntaski-1) for its lons nlonp4-1,nlonp4. ! if (mytidi==0) then ! lon0==1, send 3,4 idest = itask_table(ntaski-1,mytidj) do n=1,nf4d_hist jj = 1 do j=lat0-2,lat1+2 sndbuf(:,jj,n,1) = f4d(n)%data(:,lon0+2,j,ixt) sndbuf(:,jj,n,2) = f4d(n)%data(:,lon0+3,j,ixt) jj = jj+1 enddo enddo isrc = idest mtag = idest+mytid call mpi_sendrecv(sndbuf, len, MPI_REAL8, idest, mtag, rcvbuf, | len, MPI_REAL8, isrc, isrc+mytid+1, MPI_COMM_WORLD, status, | ier) if (ier /= 0) call handle_mpi_err(ier, | 'mp_periodic_f4d sendrecv from west end') ! ! If I am at east end of task row (mytidi==ntaski-1), send lons ! lon1-3,lon1-2 to task on west end (mytidi==0) for its lons 1,2. ! elseif (mytidi==ntaski-1) then ! lon1==nlonp4, send lon1-3,lon1-2 idest = itask_table(0,mytidj) do n=1,nf4d_hist jj = 1 do j=lat0-2,lat1+2 sndbuf(:,jj,n,1) = f4d(n)%data(:,lon1-3,j,ixt) sndbuf(:,jj,n,2) = f4d(n)%data(:,lon1-2,j,ixt) jj = jj+1 enddo enddo isrc = idest mtag = idest+mytid+1 call mpi_sendrecv(sndbuf, len, MPI_REAL8, idest, mtag, rcvbuf, | len, MPI_REAL8, isrc, isrc+mytid, MPI_COMM_WORLD, status, | ier) if (ier /= 0) call handle_mpi_err(ier, | 'mp_periodic_f4d sendrecv from east end') endif ! ! If I am on west end of task row, receive lons 1,2. ! if (mytidi==0) then ! lon0==1 do n=1,nf4d_hist jj = 1 do j=lat0-2,lat1+2 f4d(n)%data(:,lon0 ,j,ixt) = rcvbuf(:,jj,n,1) f4d(n)%data(:,lon0+1,j,ixt) = rcvbuf(:,jj,n,2) jj = jj+1 enddo enddo ! ! If I am on east end of task row, receive lons lon1-1,lon1: ! elseif (mytidi==ntaski-1) then ! lon1==nlonp4 do n=1,nf4d_hist jj = 1 do j=lat0-2,lat1+2 f4d(n)%data(:,lon1-1,j,ixt) = rcvbuf(:,jj,n,1) f4d(n)%data(:,lon1 ,j,ixt) = rcvbuf(:,jj,n,2) jj = jj+1 enddo enddo endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_periodic_f4d,tsec,'end') rtcmp_periodic_f4d = rtcmp_periodic_f4d+tsec endif #ifdef VT ! call vtsymdef(108, 'mp_periodic_f4d','Communication',ier) call vtend(108,ier) #endif end subroutine mp_periodic_f4d !----------------------------------------------------------------------- subroutine mp_periodic_f3d(f,lev0,lev1,lon0,lon1,lat0,lat1) ! ! Define periodic points for field f(nlevels,lon0:lon1,lat0:lat1): ! lons 1,2 <- nlonp4-3,nlonp4-2 and nlonp4-1,nlonp4 <- 3,4 ! ! Args: integer,intent(in) :: lev0,lev1,lon0,lon1,lat0,lat1 real,intent(inout) :: f(lev0:lev1,lon0:lon1,lat0:lat1) ! ! Local: integer :: k,j,idest,isrc,isend,irecv,ier,len,nlevs,nlons,nlats real,allocatable :: sndbuf(:,:,:),rcvbuf(:,:,:) ! (nlevs,2,nlats) ! ! The restriction that every task must carry at least 4 longitudes ! means that tasks with mytidi==0 will have lons 1->4 and tasks ! with mytidi==ntaski-1 will have lons nlonp4-3->nlonp4. ! if (mytidi /= 0 .and. mytidi /= ntaski-1) return #ifdef VT ! call vtsymdef(109, 'mp_periodic_f3d','Communication',ier) call vtbegin(109,ier) #endif if (do_rtc_mpi) call timer(rtc0_periodic_f3d,tsec,'begin') ! ! Allocate send and receive buffers: nlevs = lev1-lev0+1 nlons = lon1-lon0+1 nlats = lat1-lat0+1 allocate(sndbuf(nlevs,2,nlats),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f3d: error allocating sndbuf:', | ' nlevs=',i3,' nlats=',i3,' ier=',i4)") nlevs,nlats,ier allocate(rcvbuf(nlevs,2,nlats),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f3d: error allocating rcvbuf:', | ' nlevs=',i3,' nlats=',i3,' ier=',i4)") nlevs,nlats,ier len = nlevs*2*nlats ! ! Send lons 3,4 to lons nlonp4-1,nlonp4 at task with mytidi==ntaski-1, ! and receive lons 1,2 from the same task. if (mytidi==0) then idest = itask_table(ntaski-1,mytidj) do j=lat0,lat1 do k=lev0,lev1 sndbuf(k-lev0+1,1:2,j-lat0+1) = f(k,3:4,j) enddo enddo ! j=lat0,lat1 call mpi_isend(sndbuf,len,MPI_REAL8,idest,1,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d send to idest') isrc = idest call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,1,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d recv fm isrc') ! ! Send lons nlonp4-3,nlonp4-2 to lons 1,2 at task with mytidi==0, ! and receive lons nlonp4-1,nlonp4 from same task: elseif (mytidi==ntaski-1) then idest = itask_table(0,mytidj) do j=lat0,lat1 do k=lev0,lev1 sndbuf(k-lev0+1,1:2,j-lat0+1) = f(k,nlonp4-3:nlonp4-2,j) enddo enddo ! j=lat0,lat1 call mpi_isend(sndbuf,len,MPI_REAL8,idest,1,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d send to idest') isrc = idest call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,1,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d recv fm isrc') endif ! ! Wait for completions: call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d wait for send') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f3d wait for recv') ! ! Copy from receive buffer: if (mytidi==0) then do j=lat0,lat1 do k=lev0,lev1 f(k,1:2,j) = rcvbuf(k-lev0+1,1:2,j-lat0+1) enddo ! k=lev0,lev1 enddo ! j=lat0,lat1 elseif (mytidi==ntaski-1) then do j=lat0,lat1 do k=lev0,lev1 f(k,nlonp4-1:nlonp4,j) = rcvbuf(k-lev0+1,1:2,j-lat0+1) enddo ! k=lev0,lev1 enddo ! j=lat0,lat1 endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_periodic_f3d,tsec,'end') rtcmp_periodic_f3d = rtcmp_periodic_f3d+tsec endif #ifdef VT ! call vtsymdef(109, 'mp_periodic_f3d','Communication',ier) call vtend(109,ier) #endif end subroutine mp_periodic_f3d !----------------------------------------------------------------------- subroutine mp_periodic_f2d(f,lon0,lon1,lat0,lat1) ! ! Define periodic points for field f(lon0:lon1,lat0:lat1): ! lons 1,2 <- nlonp4-3,nlonp4-2 and nlonp4-1,nlonp4 <- 3,4 ! ! Args: integer,intent(in) :: lon0,lon1,lat0,lat1 real,intent(inout) :: f(lon0:lon1,lat0:lat1) ! ! Local: integer :: j,idest,isrc,isend,irecv,ier,len,nlons,nlats real,allocatable :: sndbuf(:,:),rcvbuf(:,:) ! (2,nlats) ! ! The restriction that every task must carry at least 4 longitudes ! means that tasks with mytidi==0 will have lons 1->4 and tasks ! with mytidi==ntaski-1 will have lons nlonp4-3->nlonp4. ! if (mytidi /= 0 .and. mytidi /= ntaski-1) return #ifdef VT ! call vtsymdef(109, 'mp_periodic_f2d','Communication',ier) call vtbegin(109,ier) #endif if (do_rtc_mpi) call timer(rtc0_periodic_f2d,tsec,'begin') ! ! Allocate send and receive buffers: nlons = lon1-lon0+1 nlats = lat1-lat0+1 allocate(sndbuf(2,nlats),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f2d: error allocating sndbuf:', | ' nlats=',i3,' ier=',i4)") nlats,ier allocate(rcvbuf(2,nlats),stat=ier) if (ier /= 0) | write(6,"('>>> mp_periodic_f2d: error allocating rcvbuf:', | ' nlats=',i3,' ier=',i4)") nlats,ier len = 2*nlats ! ! Send lons 3,4 to lons nlonp4-1,nlonp4 at task with mytidi==ntaski-1, ! and receive lons 1,2 from the same task. if (mytidi==0) then idest = itask_table(ntaski-1,mytidj) do j=lat0,lat1 sndbuf(1:2,j-lat0+1) = f(3:4,j) enddo ! j=lat0,lat1 call mpi_isend(sndbuf,len,MPI_REAL8,idest,1,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d send to idest') isrc = idest call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,1,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d recv fm isrc') ! ! Send lons nlonp4-3,nlonp4-2 to lons 1,2 at task with mytidi==0, ! and receive lons nlonp4-1,nlonp4 from same task: elseif (mytidi==ntaski-1) then idest = itask_table(0,mytidj) do j=lat0,lat1 sndbuf(1:2,j-lat0+1) = f(nlonp4-3:nlonp4-2,j) enddo ! j=lat0,lat1 call mpi_isend(sndbuf,len,MPI_REAL8,idest,1,MPI_COMM_WORLD, | isend,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d send to idest') isrc = idest call mpi_irecv(rcvbuf,len,MPI_REAL8,isrc,1,MPI_COMM_WORLD, | irecv,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d recv fm isrc') endif ! ! Wait for completions: call mpi_wait(isend,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d wait for send') call mpi_wait(irecv,irstat,ier) if (ier /= 0) | call handle_mpi_err(ier,'mp_periodic_f2d wait for recv') ! ! Copy from receive buffer: if (mytidi==0) then do j=lat0,lat1 f(1:2,j) = rcvbuf(1:2,j-lat0+1) enddo ! j=lat0,lat1 elseif (mytidi==ntaski-1) then do j=lat0,lat1 f(nlonp4-1:nlonp4,j) = rcvbuf(1:2,j-lat0+1) enddo ! j=lat0,lat1 endif ! ! Free local buffer space: deallocate(sndbuf) deallocate(rcvbuf) ! if (do_rtc_mpi) then call timer(rtc0_periodic_f2d,tsec,'end') rtcmp_periodic_f2d = rtcmp_periodic_f2d+tsec endif #ifdef VT ! call vtsymdef(109, 'mp_periodic_f2d','Communication',ier) call vtend(109,ier) #endif end subroutine mp_periodic_f2d !----------------------------------------------------------------------- subroutine mp_updatephi ! ! Dynamo has been calculated by the master task. Now send dynamo output ! field phim3d (mag coords) to the slaves (phim3d is use-associated ! from fields module at top of this module). Phim3d is dimensioned at ! the global mag grid by all tasks: phim3d(nmlonp1,nmlat,-2:nlevp1), ! but it is calculated in the dynamo by only the master task. ! ! Local: integer :: n,msgtag,ier real :: fmin,fmax ! if (mytid==0) then ! master send to slaves do n=1,ntask-1 msgtag = n call mpi_send(phim3d,nmlonp1*nmlat*(nlevp1+3),MPI_REAL8,n, | msgtag,MPI_COMM_WORLD,ier) if (ier /= 0) then write(6,"('>>> mp_updatephi: error sending', | ' phim3d from master to task ',i3,' msgtag=',i3)") | n,msgtag else ! write(6,"('mp_updatephi: master sent phim3d to task', ! | i3)") n endif enddo else ! slave receive from master msgtag = mytid call mpi_recv(phim3d,nmlonp1*nmlat*(nlevp1+3),MPI_REAL8,0, | msgtag,MPI_COMM_WORLD,irstat,ier) if (ier /= 0) then write(6,"('>>> mp_updatephi: error receiving', | ' phim3d from master at task mytid=',i3,' msgtag=',i3)") | mytid,msgtag else ! call fminmax(phim3d,nmlonp1*nmlat*(nlevp1+3),fmin,fmax) ! write(6,"('mp_updatephi: task ',i3,' received phim3d ', ! | 'from master: global min,max=',2e12.4)") mytid,fmin,fmax endif endif end subroutine mp_updatephi !----------------------------------------------------------------------- subroutine mp_close integer :: ier call mpi_finalize(ier) if (ier /= 0) then write(6,"(/,'>>> WARNING: error from mp_close: ier=',i3)") ier endif end subroutine mp_close !----------------------------------------------------------------------- subroutine handle_mpi_err(ierrcode,string) ! ! Args: integer,intent(in) :: ierrcode character(len=*) :: string ! ! Local: character(len=80) :: errstring integer :: len_errstring ! call mpi_error_string(ierrcode,errstring,len_errstring) write(6,"(/,'>>> mpi error: ',a)") trim(string) write(6,"(' ierrcode=',i3,': ',a)") trim(errstring) end subroutine handle_mpi_err #endif end module mpi_module