module seq_comm_mct 31,4 !--------------------------------------------------------------------- ! ! Purpose: MCT utitlity functions used in sequential CCSM. ! Note that if no MPI, will call MCTs fake version ! (including mpif.h) will be utilized ! ! Author: R. Jacob ! !--------------------------------------------------------------------- use mct_mod, only : mct_world_init, mct_die use shr_sys_mod, only : shr_sys_abort, shr_sys_flush use shr_mpi_mod, only : shr_mpi_chkerr, shr_mpi_bcast use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit implicit none save private !-------------------------------------------------------------------------- ! Public interfaces !-------------------------------------------------------------------------- public seq_comm_init public seq_comm_iamin public seq_comm_iamroot public seq_comm_mpicom public seq_comm_iam public seq_comm_gloiam public seq_comm_cplpe public seq_comm_cmppe public seq_comm_setptrs public seq_comm_setnthreads public seq_comm_getnthreads public seq_comm_printcomms !-------------------------------------------------------------------------- ! Public data !-------------------------------------------------------------------------- integer, public :: logunit = 6 ! log unit number integer, public :: loglevel = 1 ! log level ! NOTE: the LNDID must be 1 as this is currently hardwired in ! clm for lnd/rtm mapping. This constraint can be removed when ! clm gets the compid from the driver. integer, parameter, public :: ncomps = 12 integer, parameter, public :: LNDID = 1 integer, parameter, public :: ATMID = 2 integer, parameter, public :: OCNID = 3 integer, parameter, public :: ICEID = 4 integer, parameter, public :: GLCID = 5 integer, parameter, public :: CPLID = 6 integer, parameter, public :: GLOID = 7 integer, parameter, public :: CPLATMID = 8 integer, parameter, public :: CPLLNDID = 9 integer, parameter, public :: CPLICEID = 10 integer, parameter, public :: CPLOCNID = 11 integer, parameter, public :: CPLGLCID = 12 character(len=8),parameter,private :: IDname(ncomps) = & (/ ' LND ',' ATM ',' OCN ',' ICE ',' GLC ', & ' CPL ',' GLOBAL ',' CPLATM ',' CPLLND ',' CPLICE ', & ' CPLOCN ',' CPLGLC ' /) type seq_comm_type character(len=8) :: name ! my name, see IDname above integer :: ID ! my id number, see parameters above integer :: mpicom ! mpicom integer :: mpigrp ! mpigrp integer :: npes ! number of pes in comm integer :: nthreads ! number of omp threads per pe integer :: iam ! my pe number in mpicom logical :: iamroot ! am i the root pe in mpicom integer :: gloiam ! my pe number in mpi_comm_world integer :: pethreads ! max number of threads on my pe integer :: cplpe ! a common pe in mpicom from the cpl group for join mpicoms integer :: cmppe ! a common pe in mpicom from the component group for join mpicoms logical :: set ! has this datatype been set end type seq_comm_type type(seq_comm_type) :: seq_comms(ncomps) character(*),parameter :: F11 = "(a,a,'(',i3,a,')',a, 3i6,' (',a,i6,')',' (',a,i3,')')" character(*),parameter :: F12 = "(a,a,'(',i3,a,')',a,2i6,6x,' (',a,i6,')',' (',a,i3,')','(',a,2i6,')')" character(*),parameter :: F13 = "(a,a,'(',i3,a,')',a,2i6,6x,' (',a,i6,')',' (',a,i3,')')" #include <mpif.h> !======================================================================= contains !======================================================================= subroutine seq_comm_init(nmlfile, atm_petlist, lnd_petlist, ice_petlist, ocn_petlist, glc_petlist) 1,22 !---------------------------------------------------------- ! ! Arguments implicit none character(len=*), intent(IN) :: nmlfile integer, pointer, optional :: atm_petlist(:) integer, pointer, optional :: lnd_petlist(:) integer, pointer, optional :: ice_petlist(:) integer, pointer, optional :: ocn_petlist(:) integer, pointer, optional :: glc_petlist(:) ! ! Local variables ! integer :: ierr,n character(*),parameter :: subName = '(seq_comm_init) ' integer :: mpi_group_world ! MPI_COMM_WORLD group integer :: mype,numpes,myncomps,max_threads integer :: amin,amax,astr integer :: lmin,lmax,lstr integer :: imin,imax,istr integer :: omin,omax,ostr integer :: gmin,gmax,gstr integer :: cmin,cmax,cstr integer :: pelist(3,1) ! start, stop, stride for group integer, pointer :: comps(:) ! array with component ids integer, pointer :: comms(:) ! array with mpicoms integer :: onecomm ! single comm for "old" mct init integer :: nu, i logical,save :: first_pass = .true. ! integer :: & atm_ntasks, atm_rootpe, atm_pestride, atm_nthreads, & lnd_ntasks, lnd_rootpe, lnd_pestride, lnd_nthreads, & ice_ntasks, ice_rootpe, ice_pestride, ice_nthreads, & glc_ntasks, glc_rootpe, glc_pestride, glc_nthreads, & ocn_ntasks, ocn_rootpe, ocn_pestride, ocn_nthreads, & cpl_ntasks, cpl_rootpe, cpl_pestride, cpl_nthreads namelist /ccsm_pes/ & atm_ntasks, atm_rootpe, atm_pestride, atm_nthreads, & lnd_ntasks, lnd_rootpe, lnd_pestride, lnd_nthreads, & ice_ntasks, ice_rootpe, ice_pestride, ice_nthreads, & glc_ntasks, glc_rootpe, glc_pestride, glc_nthreads, & ocn_ntasks, ocn_rootpe, ocn_pestride, ocn_nthreads, & cpl_ntasks, cpl_rootpe, cpl_pestride, cpl_nthreads !---------------------------------------------------------- ! make sure this is first pass and set comms unset if (.not. first_pass) then write(logunit,*) trim(subname),' ERROR seq_comm_init already called ' call shr_sys_abort() endif first_pass = .false. do n = 1,ncomps seq_comms(n)%set = .false. seq_comms(n)%mpicom = MPI_COMM_NULL ! do some initialization here seq_comms(n)%iam = -1 seq_comms(n)%iamroot = .false. seq_comms(n)%npes = -1 seq_comms(n)%nthreads = -1 seq_comms(n)%gloiam = -1 seq_comms(n)%pethreads = -1 seq_comms(n)%cplpe = -1 seq_comms(n)%cmppe = -1 enddo ! Initialize MPI ! Note that if no MPI, will call MCTs fake version call mpi_init(ierr) call shr_mpi_chkerr(ierr,subname//' mpi_init') call mpi_comm_rank(MPI_COMM_WORLD, mype , ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') call mpi_comm_size(MPI_COMM_WORLD, numpes, ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') ! Initialize gloiam on all IDs do n = 1,ncomps seq_comms(n)%gloiam = mype enddo ! Initialize IDs if (mype == 0) then ! Set default values atm_ntasks=numpes; atm_rootpe=0; atm_pestride=1; atm_nthreads=1 lnd_ntasks=numpes; lnd_rootpe=0; lnd_pestride=1; lnd_nthreads=1 ice_ntasks=numpes; ice_rootpe=0; ice_pestride=1; ice_nthreads=1 glc_ntasks=numpes; glc_rootpe=0; glc_pestride=1; glc_nthreads=1 ocn_ntasks=numpes; ocn_rootpe=0; ocn_pestride=1; ocn_nthreads=1 cpl_ntasks=numpes; cpl_rootpe=0; cpl_pestride=1; cpl_nthreads=1 ! Read namelist if it exists nu = shr_file_getUnit() open(nu,file=trim(nmlfile),status='old', iostat=ierr) if (ierr == 0) then ierr = 1 do while( ierr > 0 ) read(nu, nml=ccsm_pes, iostat=ierr) end do close(nu) end if call shr_file_freeUnit(nu) !--- validation of inputs --- ! rootpes >= 0 if (atm_rootpe < 0 .or. lnd_rootpe < 0 .or. ice_rootpe < 0 .or. & ocn_rootpe < 0 .or. glc_rootpe < 0 .or. cpl_rootpe < 0) then write(logunit,*) trim(subname),' ERROR: rootpes must be >= 0' call shr_sys_abort() endif ! ! nthreads = 1, temporary ! if (atm_nthreads /= 1 .or. lnd_nthreads /= 1 .or. ice_nthreads /= 1 .or. & ! ocn_nthreads /= 1 .or. cpl_nthreads /= 1) then ! write(logunit,*) trim(subname),' ERROR: nthreads must be 1' ! call shr_sys_abort() ! endif ! ! nthreads should be 1 or something consistent, compute max nthreads ! amax = max(atm_nthreads,lnd_nthreads) ! amax = max(amax ,ice_nthreads) ! amax = max(amax ,ocn_nthreads) ! amax = max(amax ,cpl_nthreads) ! ! check that everything is either 1 or max nthreads ! if ((atm_nthreads /= 1 .and. atm_nthreads /= amax) .or. & ! (lnd_nthreads /= 1 .and. lnd_nthreads /= amax) .or. & ! (ice_nthreads /= 1 .and. ice_nthreads /= amax) .or. & ! (ocn_nthreads /= 1 .and. ocn_nthreads /= amax) .or. & ! (cpl_nthreads /= 1 .and. cpl_nthreads /= amax)) then ! write(logunit,*) trim(subname),' ERROR: nthreads must be consistent' ! call shr_sys_abort() ! endif endif ! NOTE: Only valid on root pe due to namelist read above, bcast below if (mype == 0) then amin = atm_rootpe amax = atm_rootpe + (atm_ntasks-1)*atm_pestride astr = atm_pestride lmin = lnd_rootpe lmax = lnd_rootpe + (lnd_ntasks-1)*lnd_pestride lstr = lnd_pestride imin = ice_rootpe imax = ice_rootpe + (ice_ntasks-1)*ice_pestride istr = ice_pestride omin = ocn_rootpe omax = ocn_rootpe + (ocn_ntasks-1)*ocn_pestride ostr = ocn_pestride gmin = glc_rootpe gmax = glc_rootpe + (glc_ntasks-1)*glc_pestride gstr = glc_pestride cmin = cpl_rootpe cmax = cpl_rootpe + (cpl_ntasks-1)*cpl_pestride cstr = cpl_pestride end if ! create petlist for ESMF components if(present(atm_petlist)) then call shr_mpi_bcast(atm_ntasks, MPI_COMM_WORLD, 'atm_ntasks') call shr_mpi_bcast(atm_rootpe, MPI_COMM_WORLD, 'atm_rootpe') call shr_mpi_bcast(atm_pestride, MPI_COMM_WORLD, 'atm_pestride') allocate(atm_petlist(atm_ntasks)) do i = 1, atm_ntasks atm_petlist(i) = atm_rootpe + (i-1)*atm_pestride enddo endif if(present(lnd_petlist)) then call shr_mpi_bcast(lnd_ntasks, MPI_COMM_WORLD, 'lnd_ntasks') call shr_mpi_bcast(lnd_rootpe, MPI_COMM_WORLD, 'lnd_rootpe') call shr_mpi_bcast(lnd_pestride, MPI_COMM_WORLD, 'lnd_pestride') allocate(lnd_petlist(lnd_ntasks)) do i = 1, lnd_ntasks lnd_petlist(i) = lnd_rootpe + (i-1)*lnd_pestride enddo endif if(present(ice_petlist)) then call shr_mpi_bcast(ice_ntasks, MPI_COMM_WORLD, 'ice_ntasks') call shr_mpi_bcast(ice_rootpe, MPI_COMM_WORLD, 'ice_rootpe') call shr_mpi_bcast(ice_pestride, MPI_COMM_WORLD, 'ice_pestride') allocate(ice_petlist(ice_ntasks)) do i = 1, ice_ntasks ice_petlist(i) = ice_rootpe + (i-1)*ice_pestride enddo endif if(present(ocn_petlist)) then call shr_mpi_bcast(ocn_ntasks, MPI_COMM_WORLD, 'ocn_ntasks') call shr_mpi_bcast(ocn_rootpe, MPI_COMM_WORLD, 'ocn_rootpe') call shr_mpi_bcast(ocn_pestride, MPI_COMM_WORLD, 'ocn_pestride') allocate(ocn_petlist(ocn_ntasks)) do i = 1, ocn_ntasks ocn_petlist(i) = ocn_rootpe + (i-1)*ocn_pestride enddo endif if(present(glc_petlist)) then call shr_mpi_bcast(glc_ntasks, MPI_COMM_WORLD, 'glc_ntasks') call shr_mpi_bcast(glc_rootpe, MPI_COMM_WORLD, 'glc_rootpe') call shr_mpi_bcast(glc_pestride, MPI_COMM_WORLD, 'glc_pestride') allocate(glc_petlist(glc_ntasks)) do i = 1, glc_ntasks glc_petlist(i) = glc_rootpe + (i-1)*glc_pestride enddo endif call shr_mpi_bcast(atm_nthreads,MPI_COMM_WORLD,'atm_nthreads') call shr_mpi_bcast(lnd_nthreads,MPI_COMM_WORLD,'lnd_nthreads') call shr_mpi_bcast(ocn_nthreads,MPI_COMM_WORLD,'ocn_nthreads') call shr_mpi_bcast(ice_nthreads,MPI_COMM_WORLD,'ice_nthreads') call shr_mpi_bcast(glc_nthreads,MPI_COMM_WORLD,'glc_nthreads') call shr_mpi_bcast(cpl_nthreads,MPI_COMM_WORLD,'cpl_nthreads') ! Create MPI communicator groups if (mype == 0) then pelist(1,1) = 0 pelist(2,1) = numpes-1 pelist(3,1) = 1 end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(GLOID,pelist) if (mype == 0) then pelist(1,1) = amin pelist(2,1) = amax pelist(3,1) = astr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(ATMID,pelist,atm_nthreads) if (mype == 0) then pelist(1,1) = lmin pelist(2,1) = lmax pelist(3,1) = lstr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(LNDID,pelist,lnd_nthreads) if (mype == 0) then pelist(1,1) = imin pelist(2,1) = imax pelist(3,1) = istr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(ICEID,pelist,ice_nthreads) if (mype == 0) then pelist(1,1) = gmin pelist(2,1) = gmax pelist(3,1) = gstr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(GLCID,pelist,glc_nthreads) if (mype == 0) then pelist(1,1) = omin pelist(2,1) = omax pelist(3,1) = ostr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(OCNID,pelist,ocn_nthreads) if (mype == 0) then pelist(1,1) = cmin pelist(2,1) = cmax pelist(3,1) = cstr end if call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call seq_comm_setcomm(CPLID,pelist,cpl_nthreads) call seq_comm_joincomm(CPLID,ATMID,CPLATMID) call seq_comm_joincomm(CPLID,LNDID,CPLLNDID) call seq_comm_joincomm(CPLID,ICEID,CPLICEID) call seq_comm_joincomm(CPLID,OCNID,CPLOCNID) call seq_comm_joincomm(CPLID,GLCID,CPLGLCID) max_threads = -1 do n = 1,ncomps max_threads = max(max_threads,seq_comms(n)%nthreads) enddo do n = 1,ncomps seq_comms(n)%pethreads = max_threads enddo ! Initialize MCT ! add up valid comps on local pe myncomps = 0 do n = 1,ncomps if (seq_comms(n)%mpicom /= MPI_COMM_NULL) then myncomps = myncomps + 1 endif enddo ! set comps and comms allocate(comps(myncomps),comms(myncomps),stat=ierr) if(ierr/=0) call mct_die(subName,'allocate comps comms',ierr) myncomps = 0 do n = 1,ncomps if (seq_comms(n)%mpicom /= MPI_COMM_NULL) then myncomps = myncomps + 1 if (myncomps > size(comps)) then write(logunit,*) trim(subname),' ERROR in myncomps ',myncomps,size(comps) call shr_sys_abort() endif comps(myncomps) = seq_comms(n)%ID comms(myncomps) = seq_comms(n)%mpicom onecomm = seq_comms(n)%mpicom ! if one unique comm per pe, then pick any endif enddo if (myncomps /= size(comps)) then write(logunit,*) trim(subname),' ERROR in myncomps ',myncomps,size(comps) call shr_sys_abort() endif call mct_world_init(ncomps, MPI_COMM_WORLD, comms, comps) deallocate(comps,comms) call seq_comm_printcomms() end subroutine seq_comm_init !--------------------------------------------------------- subroutine seq_comm_setcomm(ID,pelist,nthreads) 7,6 implicit none integer,intent(IN) :: ID integer,intent(IN) :: pelist(:,:) integer,intent(IN),optional :: nthreads integer :: mpigrp_world integer :: mpigrp integer :: mpicom integer :: ierr character(*),parameter :: subName = '(seq_comm_setcomm) ' if (ID < 1 .or. ID > ncomps) then write(logunit,*) subname,' ID out of range, abort ',ID call shr_sys_abort() endif call mpi_comm_group(MPI_COMM_WORLD, mpigrp_world, ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_group mpigrp_world') call mpi_group_range_incl(mpigrp_world, 1, pelist, mpigrp,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_group_range_incl mpigrp') call mpi_comm_create(MPI_COMM_WORLD, mpigrp, mpicom, ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_create mpigrp') seq_comms(ID)%set = .true. seq_comms(ID)%ID = ID seq_comms(ID)%name = IDname(ID) seq_comms(ID)%mpicom = mpicom seq_comms(ID)%mpigrp = mpigrp if (present(nthreads)) then seq_comms(ID)%nthreads = nthreads else seq_comms(ID)%nthreads = 1 endif if (mpicom /= MPI_COMM_NULL) then call mpi_comm_size(mpicom,seq_comms(ID)%npes,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_size') call mpi_comm_rank(mpicom,seq_comms(ID)%iam,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank') if (seq_comms(ID)%iam == 0) then seq_comms(ID)%iamroot = .true. else seq_comms(ID)%iamroot = .false. endif else seq_comms(ID)%npes = -1 seq_comms(ID)%iam = -1 seq_comms(ID)%nthreads = 1 seq_comms(ID)%iamroot = .false. endif if (seq_comms(ID)%iamroot) then write(logunit,F11) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & ' pelist =',pelist,' npes =',seq_comms(ID)%npes,' nthreads =',seq_comms(ID)%nthreads endif end subroutine seq_comm_setcomm !--------------------------------------------------------- subroutine seq_comm_joincomm(ID1,ID2,ID) 5,9 implicit none integer,intent(IN) :: ID1 ! src id integer,intent(IN) :: ID2 ! srd id integer,intent(IN) :: ID ! computed id integer :: mpigrp integer :: mpicom integer :: ierr integer :: n,nsize integer,allocatable :: pe_t1(:),pe_t2(:) character(*),parameter :: subName = '(seq_comm_joincomm) ' ! check that IDs are in valid range, that ID1 and ID2 have ! been set, and that ID has not been set if (ID1 < 1 .or. ID1 > ncomps) then write(logunit,*) subname,' ID1 out of range, abort ',ID1 call shr_sys_abort() endif if (ID2 < 1 .or. ID2 > ncomps) then write(logunit,*) subname,' ID2 out of range, abort ',ID2 call shr_sys_abort() endif if (ID < 1 .or. ID > ncomps) then write(logunit,*) subname,' ID out of range, abort ',ID call shr_sys_abort() endif if (.not. seq_comms(ID1)%set .or. .not. seq_comms(ID2)%set) then write(logunit,*) subname,' ID1 or ID2 not set ',ID1,ID2 call shr_sys_abort() endif if (seq_comms(ID)%set) then write(logunit,*) subname,' ID already set ',ID call shr_sys_abort() endif call mpi_group_union(seq_comms(ID1)%mpigrp,seq_comms(ID2)%mpigrp,mpigrp,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_union mpigrp') call mpi_comm_create(MPI_COMM_WORLD, mpigrp, mpicom, ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_create mpigrp') seq_comms(ID)%set = .true. seq_comms(ID)%ID = ID seq_comms(ID)%name = IDname(ID) seq_comms(ID)%mpicom = mpicom seq_comms(ID)%mpigrp = mpigrp seq_comms(ID)%nthreads = max(seq_comms(ID1)%nthreads,seq_comms(ID2)%nthreads) seq_comms(ID)%nthreads = max(seq_comms(ID)%nthreads,1) if (mpicom /= MPI_COMM_NULL) then call mpi_comm_size(mpicom,seq_comms(ID)%npes,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_size') call mpi_comm_rank(mpicom,seq_comms(ID)%iam,ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank') if (seq_comms(ID)%iam == 0) then seq_comms(ID)%iamroot = .true. else seq_comms(ID)%iamroot = .false. endif else seq_comms(ID)%npes = -1 seq_comms(ID)%iam = -1 seq_comms(ID)%iamroot = .false. endif ! needs to be excluded until mpi_group_size is added to serial mpi in mct #if (1 == 0) if (loglevel > 3) then ! some debug code to prove the join is working ok ! when joining mpicomms, the local rank may be quite different ! from either the global or local ranks of the joining comms call mpi_group_size(seq_comms(ID1)%mpigrp,nsize,ierr) allocate(pe_t1(nsize),pe_t2(nsize)) do n = 1,nsize pe_t1(n) = n-1 pe_t2(n) = -1 enddo call mpi_group_translate_ranks(seq_comms(ID1)%mpigrp, nsize, pe_t1, mpigrp, pe_t2, ierr) write(logunit,*) 'ID1 ranks ',pe_t1 write(logunit,*) 'ID1-JOIN ranks ',pe_t2 deallocate(pe_t1,pe_t2) call mpi_group_size(seq_comms(ID2)%mpigrp,nsize,ierr) allocate(pe_t1(nsize),pe_t2(nsize)) do n = 1,nsize pe_t1(n) = n-1 pe_t2(n) = -1 enddo call mpi_group_translate_ranks(seq_comms(ID2)%mpigrp, nsize, pe_t1, mpigrp, pe_t2, ierr) write(logunit,*) 'ID2 ranks ',pe_t1 write(logunit,*) 'ID2-JOIN ranks ',pe_t2 deallocate(pe_t1,pe_t2) endif #endif allocate(pe_t1(1),pe_t2(1)) pe_t1(1) = 0 call mpi_group_translate_ranks(seq_comms(ID1)%mpigrp, 1, pe_t1, mpigrp, pe_t2, ierr) seq_comms(ID)%cplpe = pe_t2(1) pe_t1(1) = 0 call mpi_group_translate_ranks(seq_comms(ID2)%mpigrp, 1, pe_t1, mpigrp, pe_t2, ierr) seq_comms(ID)%cmppe = pe_t2(1) deallocate(pe_t1,pe_t2) if (seq_comms(ID)%iamroot) then if (loglevel > 1) then write(logunit,F12) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & ' join IDs =',ID1,ID2,' npes =',seq_comms(ID)%npes, & ' nthreads =',seq_comms(ID)%nthreads, & ' cpl/cmp pes =',seq_comms(ID)%cplpe,seq_comms(ID)%cmppe else write(logunit,F13) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & ' join IDs =',ID1,ID2,' npes =',seq_comms(ID)%npes, & ' nthreads =',seq_comms(ID)%nthreads endif endif end subroutine seq_comm_joincomm !--------------------------------------------------------- subroutine seq_comm_printcomms() 1,6 implicit none character(*),parameter :: subName = '(seq_comm_printcomms) ' integer :: m,n,mype,npes,cpes,ierr character(len=256) :: iamstring character(*),parameter :: F01 = "(4x,a4,4x ,40(1x,a8))" character(*),parameter :: F02 = "(4x,i4,3x,a1,40(2x,i6,1x))" character(*),parameter :: F03 = "(4x,i4,3x,a1,a)" call mpi_comm_size(MPI_COMM_WORLD, npes , ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') call mpi_comm_rank(MPI_COMM_WORLD, mype , ierr) call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') call shr_sys_flush(logunit) call mpi_barrier(MPI_COMM_WORLD,ierr) if (mype == 0) then ! do n = 1,ncomps ! call mpi_group_size(seq_comms(n)%mpigrp, cpes, ierr) ! call shr_mpi_chkerr(ierr,subname//' mpi_group_size') ! write(logunit,*) trim(subName),' comp ntasks,nthreads ',n,trim(seq_comms(n)%name), & ! seq_comms(n)%npes,seq_comms(n)%nthreads ! enddo write(logunit,*) ' ' write(logunit,*) trim(subName),' ID layout : global pes vs local pe for each ID' write(logunit,F01) ' gpe',(seq_comms(n)%name,n=1,ncomps),'nthrds' write(logunit,F01) ' ---',(' ------ ' ,n=1,ncomps),'------' call shr_sys_flush(logunit) endif iamstring = ' ' do n = 1,ncomps if (seq_comms(n)%iam >= 0) then write(iamstring((n-1)*9+1:n*9),"(2x,i6,1x)") seq_comms(n)%iam endif enddo n = ncomps + 1 write(iamstring((n-1)*9+1:n*9),"(2x,i6,1x)") seq_comms(GLOID)%pethreads call shr_sys_flush(logunit) call mpi_barrier(MPI_COMM_WORLD,ierr) do m = 0,npes-1 if (mype == m) then ! write(logunit,F02) mype,':',(seq_comms(n)%iam,n=1,ncomps) write(logunit,F03) mype,':',trim(iamstring) if (m == npes-1) then write(logunit,*) ' ' endif endif call shr_sys_flush(logunit) call mpi_barrier(MPI_COMM_WORLD,ierr) enddo end subroutine seq_comm_printcomms !--------------------------------------------------------- subroutine seq_comm_setptrs(ID,mpicom,mpigrp,npes,nthreads,iam,iamroot,gloiam,cplpe,cmppe,pethreads) 54 implicit none integer,intent(in) :: ID integer,intent(out),optional :: mpicom integer,intent(out),optional :: mpigrp integer,intent(out),optional :: npes integer,intent(out),optional :: nthreads integer,intent(out),optional :: iam logical,intent(out),optional :: iamroot integer,intent(out),optional :: gloiam integer,intent(out),optional :: cplpe integer,intent(out),optional :: cmppe integer,intent(out),optional :: pethreads character(*),parameter :: subName = '(seq_comm_setptrs) ' if (ID < 1 .or. ID > ncomps) then write(logunit,*) subname,' ID out of range, return ',ID return endif if (present(mpicom)) then mpicom = seq_comms(ID)%mpicom endif if (present(mpigrp)) then mpigrp = seq_comms(ID)%mpigrp endif if (present(npes)) then npes = seq_comms(ID)%npes endif if (present(nthreads)) then nthreads = seq_comms(ID)%nthreads endif if (present(iam)) then iam = seq_comms(ID)%iam endif if (present(iamroot)) then iamroot = seq_comms(ID)%iamroot endif if (present(gloiam)) then gloiam = seq_comms(ID)%gloiam endif if (present(cplpe)) then cplpe = seq_comms(ID)%cplpe endif if (present(cmppe)) then cmppe = seq_comms(ID)%cmppe endif if (present(pethreads)) then pethreads = seq_comms(ID)%pethreads endif end subroutine seq_comm_setptrs !--------------------------------------------------------- subroutine seq_comm_setnthreads(nthreads) 109,1 implicit none integer,intent(in) :: nthreads character(*),parameter :: subName = '(seq_comm_setnthreads) ' #ifdef _OPENMP if (nthreads < 1) then call shr_sys_abort(subname//' ERROR: nthreads less than one') endif call omp_set_num_threads(nthreads) #endif end subroutine seq_comm_setnthreads !--------------------------------------------------------- integer function seq_comm_getnthreads() 7 implicit none integer :: omp_get_num_threads character(*),parameter :: subName = '(seq_comm_getnthreads) ' seq_comm_getnthreads = -1 #ifdef _OPENMP !$OMP PARALLEL seq_comm_getnthreads = omp_get_num_threads() !$OMP END PARALLEL #endif end function seq_comm_getnthreads !--------------------------------------------------------- logical function seq_comm_iamin(ID) 19 implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_iamin) ' if (seq_comms(ID)%iam >= 0) then seq_comm_iamin = .true. else seq_comm_iamin = .false. endif end function seq_comm_iamin !--------------------------------------------------------- logical function seq_comm_iamroot(ID) 38 implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_iamroot) ' seq_comm_iamroot = seq_comms(ID)%iamroot end function seq_comm_iamroot !--------------------------------------------------------- integer function seq_comm_mpicom(ID) implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_mpicom) ' seq_comm_mpicom = seq_comms(ID)%mpicom end function seq_comm_mpicom !--------------------------------------------------------- integer function seq_comm_iam(ID) implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_iam) ' seq_comm_iam = seq_comms(ID)%iam end function seq_comm_iam !--------------------------------------------------------- integer function seq_comm_gloiam(ID) implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_gloiam) ' seq_comm_gloiam = seq_comms(ID)%gloiam end function seq_comm_gloiam !--------------------------------------------------------- integer function seq_comm_cplpe(ID) implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_cplpe) ' seq_comm_cplpe = seq_comms(ID)%cplpe end function seq_comm_cplpe !--------------------------------------------------------- integer function seq_comm_cmppe(ID) implicit none integer,intent(in) :: ID character(*),parameter :: subName = '(seq_comm_cmppe) ' seq_comm_cmppe = seq_comms(ID)%cmppe end function seq_comm_cmppe !--------------------------------------------------------- end module seq_comm_mct