!/===========================================================================/ ! Copyright (c) 2007, The University of Massachusetts Dartmouth ! Produced at the School of Marine Science & Technology ! Marine Ecosystem Dynamics Modeling group ! All rights reserved. ! ! FVCOM has been developed by the joint UMASSD-WHOI research team. For ! details of authorship and attribution of credit please see the FVCOM ! technical manual or contact the MEDM group. ! ! ! This file is part of FVCOM. For details, see http://fvcom.smast.umassd.edu ! The full copyright notice is contained in the file COPYRIGHT located in the ! root directory of the FVCOM code. This original header must be maintained ! in all distributed versions. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! PURPOSE ARE DISCLAIMED. ! !/---------------------------------------------------------------------------/ ! CVS VERSION INFORMATION ! $Id$ ! $Name$ ! $Revision$ !/===========================================================================/ # if defined (PARTITION_SPECIAL) MODULE MOD_PAR USE MOD_TYPES USE MOD_UTILS USE LIMS, ONLY : NGL, MGL USE MOD_TIME, ONLY : MPI_TIME IMPLICIT NONE SAVE ! !--Global Information ! INTEGER, POINTER :: EL_PID(:) !!PROCESSOR OWNER OF GLOBAL ELEMENT INTEGER, POINTER :: ELID(:) !!LOCAL VALUE OF GLOBAL ELEMENT INTEGER, POINTER :: NLID(:) !!LOCAL VALUE OF GLOBAL NODE INTEGER, POINTER :: ELID_X(:) !!LOCAL VALUE OF GLOBAL ELEMENT INCLUDING HALOS INTEGER, POINTER :: NLID_X(:) !!LOCAL VALUE OF GLOBAL NODE INCLUDING HALOS ! !--Internal Information (Local) ! INTEGER, POINTER :: EGID(:) !!GLOBAL ID OF LOCAL ELEMENT INTEGER, POINTER :: NGID(:) !!GLOBAL ID OF LOCAL NODE INTEGER, POINTER :: EGID_X(:) !!GLOBAL ID OF LOCAL ELEMENT INTEGER, POINTER :: NGID_X(:) !!GLOBAL ID OF LOCAL NODE ! !--Boundary Information: Halo Elements ! INTEGER :: NHE !!NUMBER OF HALO ELEMENTS INTEGER, POINTER :: HE_LST(:) !!GLOBAL IDENTITIES OF HALO ELEMENTS INTEGER, POINTER :: HE_OWN(:) !!OWNER OF HALO ELEMENTS ! !--Boundary Information: Internal Boundary Nodes ! INTEGER :: NBN !!NUMBER OF BOUNDARY NODES INTEGER :: MX_MLT !!MAX MULTIPLICITY OF BOUNDARY NODES INTEGER, POINTER :: BN_LST(:) !!GLOBAL IDENTITY OF BOUNDARY NODES INTEGER, POINTER :: BN_LOC(:) !!LOCAL IDENTITY OF BOUNDARY NODES INTEGER, POINTER :: BN_MLT(:) !!MULTIPLICITY OF BOUNDARY NODES INTEGER, POINTER :: BN_NEY(:,:) !!NODE OWNER LIST INTEGER, POINTER :: NDE_ID(:) !! = 0 IF INTERNAL, 1 IF ON INTERNAL BOUNDARY ! !--Boundary Information: Halo Nodes ! INTEGER :: NHN !!NUMBER OF HALO NODES INTEGER, POINTER :: HN_LST(:) !!LIST OF HALO NODES INTEGER, POINTER :: HN_OWN(:) !!PRIMARY OWNER OF HALO NODES # if defined (MULTIPROCESSOR) ! !--Communication Objects [SIZE: NPROCS] ! TYPE(COMM), POINTER, DIMENSION(:) :: EC,NC,BNC ! !--MPI TYPE Objects [SIZE: NComponents] ! TYPE:: TYPE_DEF INTEGER :: NCOMPS INTEGER :: OFFSET(100) INTEGER :: BLOCKTYPE(100) INTEGER :: BLOCKCOUNT(100) END TYPE TYPE_DEF ! !--Maps for Global Array Reconstruction [SIZE: NPROCS] ! TYPE(MAP), POINTER, DIMENSION(:) :: EMAP,NMAP, LSFMAP TYPE(MAP), POINTER, DIMENSION(:) :: EXMAP,NXMAP,BCMAP TYPE MAPLINK TYPE(MAP), POINTER, DIMENSION(:) :: MAP TYPE(MAPLINK), POINTER :: NEXT END TYPE MAPLINK TYPE(MAPLINK) :: HALO_MAPS TYPE(MAPLINK) :: INTERNAL_MAPS ! !--Statistics Calculation [SIZE: NPROCS] ! INTEGER, ALLOCATABLE :: PNE(:) !!NUMBER OF ELEMENTS IN EACH PROC INTEGER, ALLOCATABLE :: PNN(:) !!NUMBER OF NODES IN EACH PROC INTEGER, ALLOCATABLE :: PNHE(:) !!NUMBER OF HALO ELEMENTS IN EACH PROC INTEGER, ALLOCATABLE :: PNBN(:) !!NUMBER OF INTERNAL BOUNDARY NODES IN EACH PROC INTEGER, ALLOCATABLE :: PMBM(:) !!MAX MULTIPLICITY OF INTERNAL BOUNDARY NODES INTEGER, ALLOCATABLE :: PNHN(:) !!NUMBER OF HALO NODES IN EACH PROC ! DEAL FOR POINTERS INTERFACE PDEAL MODULE PROCEDURE VEC_INT_PDEAL MODULE PROCEDURE ARR_INT_PDEAL MODULE PROCEDURE CUB_INT_PDEAL MODULE PROCEDURE FDA_INT_PDEAL MODULE PROCEDURE VEC_FLT_PDEAL MODULE PROCEDURE ARR_FLT_PDEAL MODULE PROCEDURE CUB_FLT_PDEAL MODULE PROCEDURE FDA_FLT_PDEAL MODULE PROCEDURE VEC_DBL_PDEAL MODULE PROCEDURE ARR_DBL_PDEAL MODULE PROCEDURE CUB_DBL_PDEAL MODULE PROCEDURE FDA_DBL_PDEAL END INTERFACE ! DEAL FOR POINTERS INTERFACE PDEAL_IO MODULE PROCEDURE VEC_INT_PDEAL_IO MODULE PROCEDURE ARR_INT_PDEAL_IO MODULE PROCEDURE CUB_INT_PDEAL_IO MODULE PROCEDURE FDA_INT_PDEAL_IO MODULE PROCEDURE VEC_FLT_PDEAL_IO MODULE PROCEDURE ARR_FLT_PDEAL_IO MODULE PROCEDURE CUB_FLT_PDEAL_IO MODULE PROCEDURE FDA_FLT_PDEAL_IO MODULE PROCEDURE VEC_DBL_PDEAL_IO MODULE PROCEDURE ARR_DBL_PDEAL_IO MODULE PROCEDURE CUB_DBL_PDEAL_IO MODULE PROCEDURE FDA_DBL_PDEAL_IO END INTERFACE ! DEAL FOR ALLOCATABLES INTERFACE ADEAL MODULE PROCEDURE VEC_INT_ADEAL MODULE PROCEDURE ARR_INT_ADEAL MODULE PROCEDURE CUB_INT_ADEAL MODULE PROCEDURE FDA_INT_ADEAL MODULE PROCEDURE VEC_FLT_ADEAL MODULE PROCEDURE ARR_FLT_ADEAL MODULE PROCEDURE CUB_FLT_ADEAL MODULE PROCEDURE FDA_FLT_ADEAL MODULE PROCEDURE VEC_DBL_ADEAL MODULE PROCEDURE ARR_DBL_ADEAL MODULE PROCEDURE CUB_DBL_ADEAL MODULE PROCEDURE FDA_DBL_ADEAL END INTERFACE ! COLLECT FOR POINTER INTERFACE PCOLLECT MODULE PROCEDURE VEC_INT_PCOLLECT MODULE PROCEDURE ARR_INT_PCOLLECT MODULE PROCEDURE CUB_INT_PCOLLECT MODULE PROCEDURE FDA_INT_PCOLLECT MODULE PROCEDURE VEC_FLT_PCOLLECT MODULE PROCEDURE ARR_FLT_PCOLLECT MODULE PROCEDURE CUB_FLT_PCOLLECT MODULE PROCEDURE FDA_FLT_PCOLLECT MODULE PROCEDURE VEC_DBL_PCOLLECT MODULE PROCEDURE ARR_DBL_PCOLLECT MODULE PROCEDURE CUB_DBL_PCOLLECT MODULE PROCEDURE FDA_DBL_PCOLLECT END INTERFACE ! COLLECT DATA TO IOPROC INTERFACE PCOLLECT_IO MODULE PROCEDURE VEC_INT_PCOLLECT_IO MODULE PROCEDURE ARR_INT_PCOLLECT_IO MODULE PROCEDURE CUB_INT_PCOLLECT_IO MODULE PROCEDURE FDA_INT_PCOLLECT_IO MODULE PROCEDURE VEC_FLT_PCOLLECT_IO MODULE PROCEDURE ARR_FLT_PCOLLECT_IO MODULE PROCEDURE CUB_FLT_PCOLLECT_IO MODULE PROCEDURE FDA_FLT_PCOLLECT_IO MODULE PROCEDURE VEC_DBL_PCOLLECT_IO MODULE PROCEDURE ARR_DBL_PCOLLECT_IO MODULE PROCEDURE CUB_DBL_PCOLLECT_IO MODULE PROCEDURE FDA_DBL_PCOLLECT_IO END INTERFACE ! COLLECT FOR ALLOCATABLES INTERFACE ACOLLECT MODULE PROCEDURE VEC_INT_ACOLLECT MODULE PROCEDURE ARR_INT_ACOLLECT MODULE PROCEDURE CUB_INT_ACOLLECT MODULE PROCEDURE FDA_INT_ACOLLECT MODULE PROCEDURE VEC_FLT_ACOLLECT MODULE PROCEDURE ARR_FLT_ACOLLECT MODULE PROCEDURE CUB_FLT_ACOLLECT MODULE PROCEDURE FDA_FLT_ACOLLECT MODULE PROCEDURE VEC_DBL_ACOLLECT MODULE PROCEDURE ARR_DBL_ACOLLECT MODULE PROCEDURE CUB_DBL_ACOLLECT MODULE PROCEDURE FDA_DBL_ACOLLECT END INTERFACE INTERFACE PEXCHANGE MODULE PROCEDURE VEC_FLT_PEXCHANGE MODULE PROCEDURE VEC_INT_PEXCHANGE MODULE PROCEDURE VEC_DBL_PEXCHANGE MODULE PROCEDURE ARR_FLT_PEXCHANGE MODULE PROCEDURE ARR_INT_PEXCHANGE MODULE PROCEDURE ARR_DBL_PEXCHANGE END INTERFACE INTERFACE AEXCHANGE MODULE PROCEDURE VEC_FLT_AEXCHANGE MODULE PROCEDURE VEC_INT_AEXCHANGE MODULE PROCEDURE VEC_DBL_AEXCHANGE MODULE PROCEDURE ARR_FLT_AEXCHANGE MODULE PROCEDURE ARR_INT_AEXCHANGE MODULE PROCEDURE ARR_DBL_AEXCHANGE END INTERFACE INTERFACE PPRINT MODULE PROCEDURE PPRINT_ARR MODULE PROCEDURE PPRINT_VEC END INTERFACE INTERFACE APRINT MODULE PROCEDURE APRINT_ARR MODULE PROCEDURE APRINT_VEC END INTERFACE !===================================================================================| CONTAINS !!INCLUDED SUBROUTINES FOLLOW !===================================================================================| SUBROUTINE INIT_MPI_ENV(MYID,NPROCS,SERIAL,PAR,MSR,MSRID) !===================================================================================| ! INITIALIZE MPI ENVIRONMENT | !===================================================================================| INTEGER, INTENT(OUT) :: MYID,NPROCS,MSRID LOGICAL, INTENT(OUT) :: SERIAL,PAR,MSR INTEGER IERR if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING INIT_MPI_ENV" IERR=0 CALL MPI_INIT(IERR) IF(IERR/=0) WRITE(*,*) "BAD MPI_INIT" CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYID,IERR) IF(IERR/=0) WRITE(*,*) "BAD MPI_COMM_RANK" CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR) IF(IERR/=0) WRITE(*,*) "BAD MPI_COMM_SIZE" MYID = MYID + 1 MSRID = 1 IF(NPROCS > 1) SERIAL=.FALSE. IF(NPROCS > 1) PAR =.TRUE. IF(MYID /= 1) MSR =.FALSE. ! INITIALIZE THE LIST OF MAPS nullify(halo_maps%next) nullify(halo_maps%map) nullify(internal_maps%next) nullify(internal_maps%map) ! USE MPI TYPES TO EXCHANGE FVCOM TIME TYPE CALL CREATE_MPI_TIME if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END INIT_MPI_ENV" RETURN END SUBROUTINE INIT_MPI_ENV !==============================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ! ! THE FOLLOWING THREE SUBROUTINES ARE USED TO DEFINE MPI TYPES WHICH ! CAN TRANSMIT FORTRAN TYPE DATA BETWEEN PROCESSORS. USE ! 'ADD_TO_MPI_TYPE' TO ADD COMPONENTS TO AN MPI TYPE. THE ORDER ! MATTERS AND MUST MATCH THE ORDER IN WHICH THE DATA IS DECLARED ! IN THE FORTRAN TYPE. SEE EXAMPLE IN particle.F ! ! ! MPI AND FORTRAN DATA TYPE NAMES ! ! !$MPI datatype $FORTRAN datatype !MPI_INTEGER INTEGER !MPI_REAL REAL !MPI_REAL8 REAL*8 !MPI_DOUBLE_PRECISION DOUBLE PRECISION !MPI_COMPLEX COMPLEX !MPI_LOGICAL LOGICAL !MPI_CHARACTER CHARACTER !MPI_BYTE - !MPI_PACKED - ! ! mod_prec.F DECLARES THE FOLLOWING EQUIVELENCE ! ! MPI_F REAL(SP) (FOR DOUBLE AND SINGLE PRECISION MODELS) ! MPI_DP REAL(DP) ! !==============================================================================| FUNCTION INIT_TYPE_DEF() RESULT(DEF) IMPLICIT NONE TYPE(TYPE_DEF) :: DEF DEF%NCOMPS = 0 DEF%BLOCKTYPE = 0 DEF%BLOCKCOUNT = 0 DEF%OFFSET = 0 END FUNCTION INIT_TYPE_DEF !==============================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: !==============================================================================| SUBROUTINE ADD_TO_MPI_TYPE(DEF,MYTYPE,COUNT) IMPLICIT NONE TYPE(TYPE_DEF) :: DEF INTEGER, INTENT(IN) :: MYTYPE INTEGER, INTENT(IN) :: COUNT INTEGER :: N, IERR INTEGER(KIND=MPI_ADDRESS_KIND) :: EXTENT,LBND ! INCRIMENT THE NUMBER OF COMPONENTS DEF%NCOMPS = DEF%NCOMPS+1 IF (DEF%NCOMPS .GT. 99) CALL FATAL_ERROR& &("ADD_TO_MPI_TYPE: More than 100 components!",& & "You must edit the TYPE_DEF and recompile!" ) N = DEF%NCOMPS ! SET THE NEW BLOCKTYPE DEF%BLOCKTYPE(N) = MYTYPE ! SET THE NEW BLOCKCOUNT DEF%BLOCKCOUNT(N) = COUNT call MPI_TYPE_GET_EXTENT(MYTYPE, LBND, EXTENT, IERR) IF(IERR /= 0) CALL FATAL_ERROR& & ("ADD_TO_MPI_TYPE: COULD NOT GET EXTENT FOR THE TYPE?") ! SET THE NEXT OFFSET (LAST ONE IS NOT USED) DEF%OFFSET(N+1) = DEF%OFFSET(N)+ COUNT * EXTENT END SUBROUTINE ADD_TO_MPI_TYPE !==============================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: !==============================================================================| SUBROUTINE CREATE_MPI_TIME IMPLICIT NONE TYPE(TYPE_DEF) :: MPIT ! ZERO THE TYPE MPIT = INIT_TYPE_DEF() !ADD EACH COMPONENT CALL ADD_TO_MPI_TYPE(MPIT,MPI_DOUBLE_PRECISION,2) ! 2 long integers ! DEFINE AND COMMIT THE TYPE MPI_TIME = CREATE_MPI_TYPE(MPIT) END SUBROUTINE CREATE_MPI_TIME !==============================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: !==============================================================================| FUNCTION CREATE_MPI_TYPE(DEF) RESULT(MYMPITYPE) IMPLICIT NONE TYPE(TYPE_DEF),INTENT(IN) :: DEF INTEGER :: MYMPITYPE INTEGER :: IERR CALL MPI_TYPE_STRUCT(DEF%NCOMPS, DEF%blockcount, DEF%offset, DEF%blocktype, mympitype, ierr) IF(IERR /= 0) CALL FATAL_ERROR& & ("CREATE_MPI_TYPE: COULD NOT CREATE MPI_TYPE_STRUCT?") CALL MPI_TYPE_COMMIT(MYMPITYPE, ierr) IF(IERR /= 0) CALL FATAL_ERROR& & ("CREATE_MPI_TYPE: COULD NOT COMMIT MPI TYPE") END FUNCTION CREATE_MPI_TYPE !==============================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: # if !defined (METIS_5) !==============================================================================| SUBROUTINE DOMDEC(NGL,NVG,NPROCS,EL_PID,MSR) !==============================================================================| # if defined (THIN_DAM) USE control, only : casename,input_dir USE Mod_Utils, only: pstop # endif USE control, only : MPI_COMM_FVCOM IMPLICIT NONE INTEGER, INTENT(IN) :: NGL INTEGER, INTENT(IN) :: NVG(0:NGL,4) INTEGER, INTENT(IN) :: NPROCS INTEGER, INTENT(OUT) :: EL_PID(NGL) LOGICAL, INTENT(IN) :: MSR INTEGER, ALLOCATABLE :: NVT(:) INTEGER :: I,J,COUNT,NTEMP,IERR,ii # if defined (THIN_DAM) character(len=120) :: cellfile,nodefile INTEGER :: n,corner_proc_id,corner_elem,processor logical :: fexist INTEGER ,ALLOCATABLE :: NODE_DAM1(:,:),NODE_DAM2(:,:),NODE_DAM3(:,:) INTEGER ,ALLOCATABLE :: CELL_DAM(:,:),CELL_PROC(:),NODE_PROC(:) INTEGER ,ALLOCATABLE :: HOST(:) REAL(SP),ALLOCATABLE :: D_DAM1(:,:),D_DAM2(:,:),D_DAM3(:,:) INTEGER :: NN_DAM1,NN_DAM2,NN_DAM3,NC_DAM,DAM_NPROCS integer(kind=8) ,allocatable :: dxadj(:),dadjncy(:) ! type(idxtype),allocatable :: dxadj(:),dadjncy(:) integer :: nvertex,nedge,jj,kk,nbnd integer :: edge1(2),edge2(2),edge3(2) integer :: count1,count2,count3 logical :: bexist1,bexist2,bexist3 # endif !==============================================================================| if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING DOMDEC" ! !----------------CONVERT NVG to 1D-----------------------! ! IF(MSR) THEN ALLOCATE(NVT(3*NGL)) DO I=1,NGL DO J = 1,3 COUNT = (I-1)*3 + J ! FVCOM SWITCHES NODE ORDER NVT(COUNT) = NVG(I,5-J) END DO END DO !# if defined (THIN_DAM) ! nbnd = 0 ! do i=1,ngl ! edge1(1)=nvg(i,1);edge1(2)=nvg(i,2) ! edge2(1)=nvg(i,2);edge2(2)=nvg(i,3) ! edge3(1)=nvg(i,3);edge3(2)=nvg(i,1) ! bexist1=.true.; bexist2=.true.; bexist3=.true. ! do ii=1,ngl ! if(i/=ii)then ! count1=0; count2=0;count3=0 ! do kk=1,3 ! if(nvg(ii,kk)==edge1(1))count1=count1+1 ! if(nvg(ii,kk)==edge1(2))count1=count1+1 ! if(nvg(ii,kk)==edge2(1))count2=count2+1 ! if(nvg(ii,kk)==edge2(2))count2=count2+1 ! if(nvg(ii,kk)==edge3(1))count3=count3+1 ! if(nvg(ii,kk)==edge3(2))count3=count3+1 ! end do ! if(count1==2)bexist1=.false. ! if(count2==2)bexist2=.false. ! if(count3==2)bexist3=.false. ! end if ! end do ! if(bexist1.or.bexist2.or.bexist3)then ! nbnd = nbnd + 1 ! end if ! end do ! nedge = mgl*10 !(3*ngl+nbnd)/2*2 ! nvertex = mgl*2 ! print*,'nvertex = ',nvertex ! print*,'nedge = ',nedge ! allocate(dxadj(nvertex)) ! allocate(dadjncy(nedge)) ! dxadj = 0 ! dadjncy = 0 ! print*,'before mesh-to-nodal' ! CALL METIS_MESHTODUAL(NGL,MGL,loc(NVT),1,1,loc(dxadj),loc(dadjncy)) ! call mesh2nodal(NGL,MGL,loc(NVT),1,1,loc(dxadj),loc(dadjncy)) ! print*,'after mesh-to-nodal' !# endif ! !-------------DECOMPOSE ELEMENTS USING METIS GRAPH PARTITIONING ---------------! ! !$ CALL PARTITION(NPROCS,NGL,MAXVAL(NVT),loc(NVT),loc(EL_PID)) !$ EL_PID = EL_PID + 1 # if defined (THIN_DAM) cellfile = "./"//trim(input_dir)//"/"//trim(casename)//'_dam_cell.dat' nodefile = "./"//trim(input_dir)//"/"//trim(casename)//'_dam_node.dat' inquire(file=trim(cellfile),exist=fexist) if(.not.fexist)then write(*,*)'dam cell file: ',trim(cellfile),' does not exist' write(*,*)'stopping' call pstop end if inquire(file=trim(nodefile),exist=fexist) if(.not.fexist)then write(*,*)'dam node file: ',trim(nodefile),' does not exist' write(*,*)'stopping' call pstop end if !---read in nodes list. --------------------- OPEN(111,FILE=trim(nodefile),status='old') !---read in type 1 dam. --------------------- READ(111,*) READ(111,*) NN_DAM1 print*,'dam1:',nn_dam1 ALLOCATE(NODE_DAM1(NN_DAM1,2)); NODE_DAM1 = 0 ALLOCATE(D_DAM1(NN_DAM1,2)); D_DAM1 = 0 DO I=1,NN_DAM1 READ(111,*) NODE_DAM1(I,1),NODE_DAM1(I,2),D_DAM1(I,1),D_DAM1(I,2) END DO !---read in type 2 dam. --------------------- READ(111,*) READ(111,*) NN_DAM2 print*,'dam2:',nn_dam2 ALLOCATE(NODE_DAM2(NN_DAM2,3)); NODE_DAM2 = 0 ALLOCATE(D_DAM2(NN_DAM2,3)); D_DAM2 = 0 DO I=1,NN_DAM2 READ(111,*) NODE_DAM2(I,1),NODE_DAM2(I,2),NODE_DAM2(I,3), & D_DAM2(I,1),D_DAM2(I,2),D_DAM2(I,3) END DO !---read in type 3 dam. --------------------- READ(111,*) READ(111,*) NN_DAM3 print*,'dam3:',nn_dam3 ALLOCATE(NODE_DAM3(NN_DAM2,4)); NODE_DAM3 = 0 ALLOCATE(D_DAM3(NN_DAM3,4)); D_DAM3 = 0 DO I=1,NN_DAM3 READ(111,*) NODE_DAM3(I,1),NODE_DAM3(I,2),NODE_DAM3(I,3),NODE_DAM3(I,4), & D_DAM3(I,1),D_DAM3(I,2),D_DAM3(I,3),D_DAM3(I,4) END DO CLOSE(111) !---read in cells list. --------------------- OPEN(111,FILE=trim(cellfile)) READ(111,*) NC_DAM ALLOCATE(CELL_DAM(NC_DAM,2)); CELL_DAM = 0 ALLOCATE(CELL_PROC(NGL)); CELL_PROC = 0 ALLOCATE(NODE_PROC(MGL)); NODE_PROC = 0 DO I=1,NC_DAM READ(111,*) CELL_DAM(I,1),CELL_DAM(I,2),PROCESSOR CELL_PROC(CELL_DAM(I,1))=PROCESSOR CELL_PROC(CELL_DAM(I,2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),1))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),3))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),1))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),3))=PROCESSOR END DO CLOSE(111) DAM_NPROCS = MAXVAL(CELL_PROC) !$ allocate(host(NPROCS)); host = 0 !$! corner_elem = 1 !global element # of corner element !$! corner_proc_id = el_pid(corner_elem) !METIS-assigned owner of corner element ! partition with decreased CPU number CALL PARTITION(NPROCS-DAM_NPROCS,NGL,MAXVAL(NVT),loc(NVT),loc(EL_PID)) EL_PID = EL_PID + 1 ! set additional domains for dam cells do n=1,ngl do i=1,nn_dam1 if( nvg(n,2)==node_dam1(i,1).or.nvg(n,2)==node_dam1(i,2) & &.or.nvg(n,3)==node_dam1(i,1).or.nvg(n,3)==node_dam1(i,2) & &.or.nvg(n,4)==node_dam1(i,1).or.nvg(n,4)==node_dam1(i,2) )then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam1(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do do i=1,nn_dam2 if( nvg(n,2)==node_dam2(i,1).or.nvg(n,2)==node_dam2(i,2) & & .or.nvg(n,2)==node_dam2(i,3).or.nvg(n,3)==node_dam2(i,1) & & .or.nvg(n,3)==node_dam2(i,2).or.nvg(n,3)==node_dam2(i,3) & & .or.nvg(n,4)==node_dam2(i,1).or.nvg(n,4)==node_dam2(i,2) & & .or.nvg(n,4)==node_dam2(i,3))then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam2(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do do i=1,nn_dam3 if(nvg(n,2)==node_dam3(i,1).or.nvg(n,2)==node_dam3(i,2) & &.or.nvg(n,2)==node_dam3(i,3).or.nvg(n,2)==node_dam3(i,4) & &.or.nvg(n,3)==node_dam3(i,1).or.nvg(n,3)==node_dam3(i,2) & &.or.nvg(n,3)==node_dam3(i,3).or.nvg(n,3)==node_dam3(i,4) & &.or.nvg(n,4)==node_dam3(i,1).or.nvg(n,4)==node_dam3(i,2) & &.or.nvg(n,4)==node_dam3(i,3).or.nvg(n,4)==node_dam3(i,4) )then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam3(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do end do deallocate(cell_dam) deallocate(NODE_DAM1,NODE_DAM2,NODE_DAM3) deallocate(D_DAM1,D_DAM2,D_DAM3) deallocate(NODE_PROC,CELL_PROC) # else CALL PARTITION(NPROCS,NGL,MAXVAL(NVT),loc(NVT),loc(EL_PID)) EL_PID = EL_PID + 1 # endif DEALLOCATE(NVT) END IF !---------------------BROADCAST RESULT TO ALL PROCESSORS-----------------------! CALL MPI_BCAST(EL_PID,NGL,MPI_INTEGER,0,MPI_COMM_FVCOM,IERR) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END DOMDEC" END SUBROUTINE DOMDEC !===================================================================================| # else !------------------------------------------------------------------------------ !==============================================================================| SUBROUTINE DOMDEC(NGL,NVG,NPROCS,EL_PID,MSR) !==============================================================================| !Hierarchical partitioning using METIS ! ! G. Cowles, April 2016 ! USE CONTROL, ONLY : casename,NMLUNIT IMPLICIT NONE INTEGER, INTENT(IN) :: NGL INTEGER, INTENT(IN) :: NVG(0:NGL,4) INTEGER, INTENT(IN) :: NPROCS INTEGER, INTENT(OUT) :: EL_PID(NGL) LOGICAL, INTENT(IN) :: MSR !local INTEGER :: I,J,NN,E,NS INTEGER :: ICOUNT,NNODE,CNT,NLOC,MLOC,ICNT INTEGER :: IOS,IERR CHARACTER(lEN=120):: FNAME INTEGER :: OPTIONS(40) INTEGER :: NCOMMON INTEGER :: OBJVAL INTEGER, ALLOCATABLE :: NVT(:,:) INTEGER, ALLOCATABLE :: ECOUNT(:) LOGICAL, ALLOCATABLE :: ISP(:),ISP2(:) INTEGER, ALLOCATABLE :: EL_LID(:),L2G(:),NVL(:,:),G2L(:),TMP(:) INTEGER, ALLOCATABLE :: EL_PID2(:) ! !--Variables Used to Control Metis in Domain Decomposition ! INTEGER, PARAMETER :: & METIS_OPTION_PTYPE = 1, & METIS_OPTION_OBJTYPE = 2, & METIS_OPTION_CTYPE = 3, & METIS_OPTION_IPTYPE = 4, & METIS_OPTION_RTYPE = 5, & METIS_OPTION_DBGLVL = 6, & METIS_OPTION_NITER = 7, & METIS_OPTION_NCUTS = 8, & METIS_OPTION_SEED = 9, & METIS_OPTION_NO2HOP = 10, & METIS_OPTION_MINCONN = 11, & METIS_OPTION_CONTIG = 12, & METIS_OPTION_COMPRESS = 13, & METIS_OPTION_CCORDER = 14, & METIS_OPTION_PFACTOR = 15, & METIS_OPTION_NSEPS = 16, & METIS_OPTION_UFACTOR = 17, & METIS_OPTION_NUMBERING = 18, & METIS_OPTION_HELP = 19, & METIS_OPTION_TPWGTS = 20, & METIS_OPTION_NCOMMON = 21, & METIS_OPTION_NOOUTPUT = 22, & METIS_OPTION_BALANCE = 23, & METIS_OPTION_GTYPE = 24, & METIS_OPTION_UBVEC = 25 ! !--Partitioning Control Params ! INTEGER :: PART_NLEVS INTEGER :: LEV2_NPROCS, PART_LEV1_NPROCS REAL(SP) :: IMB_MAX, IMB_ALL_MAX INTEGER :: ALL_PAR_MAX, ALL_PAR_MIN INTEGER :: OPTION_NUMBERING, & OPTION_NCOMMON, & LEV1_OPTION_PTYPE, & LEV1_OPTION_NITER, & LEV1_OPTION_UFACTOR, & LEV1_OPTION_IPTYPE, & LEV1_OPTION_RTYPE, & LEV1_OPTION_NCUTS, & LEV2_OPTION_PTYPE, & LEV2_OPTION_NITER, & LEV2_OPTION_UFACTOR, & LEV2_OPTION_IPTYPE, & LEV2_OPTION_RTYPE, & LEV2_OPTION_NCUTS NAMELIST /NML_PARTITION/ & ! See page 21-23 of METIS-5.1.x Manual for more & PART_NLEVS, & ! number of partitioning levels (1 or 2) & LEV2_NPROCS, & ! number of level2 processes in each level1 process & LEV1_OPTION_PTYPE, & ! level 1 partitioning method [multilevel recursive bisection, k-way] & LEV1_OPTION_NITER, & ! number of iterations at each stage of uncoarsings process & LEV1_OPTION_UFACTOR, & ! maximum allowed load imbalance [1 = 0.1%] (rb=1, kway=30) & LEV1_OPTION_IPTYPE, & ! algorithm for initial partitioning [see metis manual for options] & LEV1_OPTION_RTYPE, & ! algorithm for refinement [see metis manual for options] & LEV2_OPTION_PTYPE, & ! level 2 partitioning method [multilevel recursive bisection, k-way] & LEV2_OPTION_NITER, & ! number of iterations at each stage of uncoarsings process & LEV2_OPTION_UFACTOR, & ! maximum allowed load imbalance [1 = 0.1%] (rb=1, kway=30) & LEV2_OPTION_IPTYPE, & ! algorithm for initial partitioning [see metis manual] & LEV2_OPTION_RTYPE ! algorithm for refinement [see metis manual] IF(MSR)THEN ! initialize metis control parameters options = -1 option_numbering = 1 option_ncommon = 2 !initialize the namelist values [-1 will produce Metis default] part_nlevs = 1 lev2_nprocs = 1 lev1_option_ptype = 1 !use k-way for default lev1_option_niter = -1 !metis default lev1_option_ufactor = -1 !metis default lev1_option_iptype = -1 !metis default lev1_option_rtype = -1 !metis default lev2_option_ptype = 1 !use k-way for default lev2_option_niter = -1 !metis default lev2_option_ufactor = -1 !metis default lev2_option_iptype = -1 !metis default lev2_option_rtype = -1 !metis default ! read the partition control namelist from the runtime file ! fname = "./"//trim(casename)//"_run.nml" ! call fopen(nmlunit,trim(fname),'cfr') ! read(unit=nmlunit, nml=nml_partition,iostat=IOS) ! if(ios .ne. 0 ) then ! write(ipt,*)'cannot read nml_partition from runtime file' ! write(unit=ipt,nml=nml_partition) ! call fatal_error("cannot read nml_partition from runtime file") ! end if ! rewind(nmlunit) ! close(nmlunit) !------------------------------------------------- ! sanity check on namelist values !------------------------------------------------- ! sanity on part_nlevs if(part_nlevs < 1) part_nlevs = 1 if(part_nlevs > 2) part_nlevs = 2 !check partitioning approach if(lev1_option_ptype /= 0 .and. lev1_option_ptype /= 1)then call fatal_error("level 1 partitioning method must be 'mrb' or 'kway'") endif if(part_nlevs > 1)then if(lev2_option_ptype /= 0 .and. lev2_option_ptype /= 1)then call fatal_error("level 2 partitioning method must be 'mrb' or 'kway'") endif endif ! no hierarchical partition, set parameters if(part_nlevs==1)then part_lev1_nprocs = nprocs !NO HIERARCHICAL PARTITIONING endif ! 2-level partitioning, if #lev2_nprocs > nprocs, set it to nprocs if(part_nlevs == 2) lev2_nprocs = min(lev2_nprocs,nprocs) ! 2-level partition, make sure part_lev1_nprocs is integral number if(part_nlevs == 2)then if(mod(NPROCS,LEV2_NPROCS)==0)then part_lev1_nprocs = nprocs/lev2_nprocs else write(ipt,*)'nprocs: ',nprocs write(ipt,*)'lev2_nprocs',lev2_nprocs Call Fatal_Error("lev2_nprocs must be a common factor of nprocs") endif endif !2-level partition but lev2_nprocs is 1, this is same as 1-level if(lev2_nprocs==1) part_nlevs = 1 allocate(nvt(3,ngl)); nvt = 0; do i=1,ngl nvt(1,i) = nvg(i,1) nvt(2,i) = nvg(i,3) nvt(3,i) = nvg(i,2) end do !------------------------------------------------------------------------- ! partition at level 1 (node level) !------------------------------------------------------------------------- options = -1 !set all metis options to default options(METIS_OPTION_NUMBERING) = option_numbering ncommon = option_ncommon options(METIS_OPTION_PTYPE) = lev1_option_ptype options(METIS_OPTION_NITER) = lev1_option_niter options(METIS_OPTION_UFACTOR) = lev1_option_ufactor options(METIS_OPTION_IPTYPE) = lev1_option_iptype options(METIS_OPTION_RTYPE) = lev1_option_rtype nnode = maxval(nvt) !partition write(*,*)'calling partition with elements nodes',ngl,nnode write(*,*)'calling partition with partitions ',part_lev1_nprocs write(*,*)'partition info: ',ngl,nnode,ncommon,objval if(lev1_option_ptype == 0)then write(*,*)'Using RCB partitioner on LEV1' else write(*,*)'Using kway partitioner on LEV1' endif if(part_lev1_nprocs > 1)then # if defined (THIN_DAM) call DOMDEC_DAM(NGL,NVG,NPROCS,EL_PID,nvt,ncommon,options,objval,MSR) # else call partition(part_lev1_nprocs, ngl, nnode, ncommon, loc(nvt), loc(options), loc(el_pid),objval) # endif else !no need to partition el_pid = 1 endif write(*,*)'partition done' !need load balance diagnostics for 1st level partition allocate(isp(ngl)); isp = .false. allocate(ecount(part_lev1_nprocs)) do i=1,part_lev1_nprocs isp = (el_pid==i) ecount(i) = count(isp) write(*,*)i,ecount(i) end do write(*,*)'level1 imbalance:',100*(1-float(minval(ecount))/float(maxval(ecount))) write(*,*)'level 1 edgecut: ',objval deallocate(ecount) deallocate(isp) !------------------------------------------------------------------------- ! partition at level 2 !------------------------------------------------------------------------- if(part_nlevs > 1)then imb_max = -1e9 !initialize max imbalance allocate(isp(ngl)); isp = .false. allocate(el_pid2(ngl)); el_pid2 = 0 write(*,*)'=== processing level 2===' write(*,*) do nn=1,part_lev1_nprocs isp = .false. isp = (el_pid==nn) nloc = count(isp) allocate(el_lid(nloc)); el_lid = 0 allocate(l2g(nloc)); l2g = 0 allocate(nvl(3,nloc)); nvl = 0 write(*,*)'=> partitioning level 1 partition ',nn,' of size ',nloc !get a list of elements in the node partition cnt = 0 do e=1,ngl if(el_pid(e)==nn)then cnt = cnt + 1 l2g(cnt) = e nvl(:,cnt) = nvt(:,e) endif end do ! reorder the local connectivity allocate(tmp(nnode)); tmp = 0 do i=1,nloc tmp(nvl(1,i)) = 1 tmp(nvl(2,i)) = 1 tmp(nvl(3,i)) = 1 end do mloc = sum(tmp) allocate(g2l(nnode)); g2l = 0 icnt = 0 do i=1,nnode if(tmp(i)==1)then icnt = icnt + 1 g2l(i) = icnt endif end do do i=1,nloc nvl(1,i) = g2l(nvl(1,i)) nvl(2,i) = g2l(nvl(2,i)) nvl(3,i) = g2l(nvl(3,i)) end do deallocate(tmp) deallocate(g2l) !partition the local domain into numlev2parts options = -1 !set all metis options to default options(METIS_OPTION_NUMBERING) = option_numbering ncommon = option_ncommon options(METIS_OPTION_PTYPE) = lev2_option_ptype options(METIS_OPTION_NITER) = lev2_option_niter options(METIS_OPTION_UFACTOR) = lev2_option_ufactor options(METIS_OPTION_IPTYPE) = lev2_option_iptype options(METIS_OPTION_RTYPE) = lev2_option_rtype if(lev2_option_ptype == 0)then write(*,*)'Using RCB partitioner on LEV2' else write(*,*)'Using kway partitioner on LEV2' endif call partition(lev2_nprocs, nloc, mloc, ncommon, loc(nvl), loc(options), loc(el_lid), objval) !check level 2 load balance allocate(isp2(nloc)); isp2 = .false. allocate(ecount(lev2_nprocs)) do ns=1,lev2_nprocs isp2 = (el_lid==ns) ecount(ns) = count(isp2) write(*,*)'level 2 partition ',ns,' size ',ecount(ns) end do write(*,*)'load imbalance:',nn,100*(1-float(minval(ecount))/float(maxval(ecount))) imb_max = max(imb_max,100*(1-float(minval(ecount))/float(maxval(ecount)))) all_par_max = 0; all_par_min = 100 all_par_max = max(all_par_max,maxval(ecount)) all_par_min = min(all_par_min,minval(ecount)) deallocate(ecount) deallocate(isp2) !store the partition id in el_pid do e=1,nloc el_pid2(l2g(e)) = el_lid(e)+(nn-1)*lev2_nprocs enddo deallocate(nvl) deallocate(el_lid) deallocate(l2g) end do !loop over nodes (counter n) imb_all_max = 100*(float(all_par_min)/float(all_par_max)) write(*,*)'max level 2 load imbalance: ',imb_max write(*,*)'max load imbalance of all the partitions: ',imb_all_max el_pid = el_pid2 !transfer to el_pid for return to caller ! clean up deallocate(isp) deallocate(el_pid2) endif !Hierarchical deallocate(nvt) endif !MSR !Broadcast the partition (el_pid) to everybody CALL MPI_BCAST(EL_PID,NGL,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) END SUBROUTINE DOMDEC !------------------------------------------------------------------------------ !==============================================================================| SUBROUTINE DOMDEC_DAM(NGL,NVG,NPROCS,EL_PID,nvt,ncommon,options,objval,MSR) !==============================================================================| USE control, only : casename,input_dir USE Mod_Utils, only: pstop IMPLICIT NONE INTEGER, INTENT(IN) :: NGL INTEGER, INTENT(IN) :: NVG(0:NGL,4) INTEGER, INTENT(IN) :: NPROCS INTEGER, INTENT(OUT) :: EL_PID(NGL) LOGICAL, INTENT(IN) :: MSR INTEGER :: NCOMMON,OBJVAL,OPTIONS(40),NVT(3,NGL) INTEGER :: I,NNODE character(len=120) :: cellfile,nodefile INTEGER :: n,corner_proc_id,corner_elem,processor logical :: fexist INTEGER ,ALLOCATABLE :: NODE_DAM1(:,:),NODE_DAM2(:,:),NODE_DAM3(:,:) INTEGER ,ALLOCATABLE :: CELL_DAM(:,:),CELL_PROC(:),NODE_PROC(:) INTEGER ,ALLOCATABLE :: HOST(:) REAL(SP),ALLOCATABLE :: D_DAM1(:,:),D_DAM2(:,:),D_DAM3(:,:) INTEGER :: NN_DAM1,NN_DAM2,NN_DAM3,NC_DAM,DAM_NPROCS integer(kind=8) ,allocatable :: dxadj(:),dadjncy(:) ! type(idxtype),allocatable :: dxadj(:),dadjncy(:) integer :: nvertex,nedge,jj,kk,nbnd integer :: edge1(2),edge2(2),edge3(2) integer :: count1,count2,count3 logical :: bexist1,bexist2,bexist3 !==============================================================================| cellfile = "./"//trim(input_dir)//"/"//trim(casename)//'_dam_cell.dat' nodefile = "./"//trim(input_dir)//"/"//trim(casename)//'_dam_node.dat' inquire(file=trim(cellfile),exist=fexist) if(.not.fexist)then write(*,*)'dam cell file: ',trim(cellfile),' does not exist' write(*,*)'stopping' call pstop end if inquire(file=trim(nodefile),exist=fexist) if(.not.fexist)then write(*,*)'dam node file: ',trim(nodefile),' does not exist' write(*,*)'stopping' call pstop end if !---read in nodes list. --------------------- OPEN(111,FILE=trim(nodefile),status='old') !---read in type 1 dam. --------------------- READ(111,*) READ(111,*) NN_DAM1 print*,'dam1:',nn_dam1 ALLOCATE(NODE_DAM1(NN_DAM1,2)); NODE_DAM1 = 0 ALLOCATE(D_DAM1(NN_DAM1,2)); D_DAM1 = 0 DO I=1,NN_DAM1 READ(111,*) NODE_DAM1(I,1),NODE_DAM1(I,2),D_DAM1(I,1),D_DAM1(I,2) END DO !---read in type 2 dam. --------------------- READ(111,*) READ(111,*) NN_DAM2 print*,'dam2:',nn_dam2 ALLOCATE(NODE_DAM2(NN_DAM2,3)); NODE_DAM2 = 0 ALLOCATE(D_DAM2(NN_DAM2,3)); D_DAM2 = 0 DO I=1,NN_DAM2 READ(111,*) NODE_DAM2(I,1),NODE_DAM2(I,2),NODE_DAM2(I,3), & D_DAM2(I,1),D_DAM2(I,2),D_DAM2(I,3) END DO !---read in type 3 dam. --------------------- READ(111,*) READ(111,*) NN_DAM3 print*,'dam3:',nn_dam3 ALLOCATE(NODE_DAM3(NN_DAM2,4)); NODE_DAM3 = 0 ALLOCATE(D_DAM3(NN_DAM3,4)); D_DAM3 = 0 DO I=1,NN_DAM3 READ(111,*) NODE_DAM3(I,1),NODE_DAM3(I,2),NODE_DAM3(I,3),NODE_DAM3(I,4), & D_DAM3(I,1),D_DAM3(I,2),D_DAM3(I,3),D_DAM3(I,4) END DO CLOSE(111) !---read in cells list. --------------------- OPEN(111,FILE=trim(cellfile)) READ(111,*) NC_DAM ALLOCATE(CELL_DAM(NC_DAM,2)); CELL_DAM = 0 ALLOCATE(CELL_PROC(NGL)); CELL_PROC = 0 ALLOCATE(NODE_PROC(MGL)); NODE_PROC = 0 DO I=1,NC_DAM READ(111,*) CELL_DAM(I,1),CELL_DAM(I,2),PROCESSOR CELL_PROC(CELL_DAM(I,1))=PROCESSOR CELL_PROC(CELL_DAM(I,2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),1))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,1),3))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),1))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),2))=PROCESSOR NODE_PROC(NVG(CELL_DAM(I,2),3))=PROCESSOR END DO CLOSE(111) DAM_NPROCS = MAXVAL(CELL_PROC) NNODE = maxval(nvt) ! partition with decreased CPU number CALL PARTITION(NPROCS-DAM_NPROCS,NGL,NNODE,NCOMMON,loc(NVT),loc(options),loc(EL_PID),objval) ! EL_PID = EL_PID + 1 ! set additional domains for dam cells do n=1,ngl do i=1,nn_dam1 if( nvg(n,2)==node_dam1(i,1).or.nvg(n,2)==node_dam1(i,2) & &.or.nvg(n,3)==node_dam1(i,1).or.nvg(n,3)==node_dam1(i,2) & &.or.nvg(n,4)==node_dam1(i,1).or.nvg(n,4)==node_dam1(i,2) )then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam1(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do do i=1,nn_dam2 if( nvg(n,2)==node_dam2(i,1).or.nvg(n,2)==node_dam2(i,2) & & .or.nvg(n,2)==node_dam2(i,3).or.nvg(n,3)==node_dam2(i,1) & & .or.nvg(n,3)==node_dam2(i,2).or.nvg(n,3)==node_dam2(i,3) & & .or.nvg(n,4)==node_dam2(i,1).or.nvg(n,4)==node_dam2(i,2) & & .or.nvg(n,4)==node_dam2(i,3))then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam2(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do do i=1,nn_dam3 if(nvg(n,2)==node_dam3(i,1).or.nvg(n,2)==node_dam3(i,2) & &.or.nvg(n,2)==node_dam3(i,3).or.nvg(n,2)==node_dam3(i,4) & &.or.nvg(n,3)==node_dam3(i,1).or.nvg(n,3)==node_dam3(i,2) & &.or.nvg(n,3)==node_dam3(i,3).or.nvg(n,3)==node_dam3(i,4) & &.or.nvg(n,4)==node_dam3(i,1).or.nvg(n,4)==node_dam3(i,2) & &.or.nvg(n,4)==node_dam3(i,3).or.nvg(n,4)==node_dam3(i,4) )then el_pid(n)=NPROCS-DAM_NPROCS+NODE_PROC(node_dam3(i,1)) !$ host(el_pid(n))=host(el_pid(n))+1 exit end if end do end do deallocate(cell_dam) deallocate(NODE_DAM1,NODE_DAM2,NODE_DAM3) deallocate(D_DAM1,D_DAM2,D_DAM3) deallocate(NODE_PROC,CELL_PROC) END SUBROUTINE DOMDEC_DAM !===================================================================================| # endif !------------------------------------------------------------------------------ !===================================================================================| SUBROUTINE VEC_FLT_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET :: A(:) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:) REAL(SPA), POINTER :: AP(:) REAL(SPA), POINTER :: BP(:) REAL(SPA), POINTER :: CP(:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL VEC_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL VEC_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL VEC_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL VEC_FLT_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE VEC_FLT_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE VEC_FLT_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(SPA), INTENT(INOUT), POINTER :: A(:) REAL(SPA), INTENT(INOUT), POINTER, OPTIONAL :: B(:) REAL(SPA), INTENT(INOUT), POINTER, OPTIONAL :: C(:) INTEGER :: NT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1) = ",Size(A,1) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& & write(IPT,*) "SIZE(B,1) = ",Size(B,1) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& & write(IPT,*) "SIZE(C,1) = ",Size(C,1) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS + 1 LBUF = NVARS * CM(I)%NRCV CALL MPI_IRECV(RBUF(LP),LBUF,MPI_REAL,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:)) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:)) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:)) END IF TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_REAL,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS LBUF = CM(LPROC)%NRCV N2 = LP N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_FLT_EXCHANGE" RETURN END SUBROUTINE VEC_FLT_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE VEC_INT_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET :: A(:) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:) INTEGER, POINTER :: AP(:) INTEGER, POINTER :: BP(:) INTEGER, POINTER :: CP(:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL VEC_INT_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL VEC_INT_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL VEC_INT_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL VEC_INT_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE VEC_INT_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE VEC_INT_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) INTEGER, INTENT(INOUT), POINTER :: A(:) INTEGER, INTENT(INOUT), POINTER, OPTIONAL :: B(:) INTEGER, INTENT(INOUT), POINTER, OPTIONAL :: C(:) INTEGER :: NT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1) = ",Size(A,1) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& & write(IPT,*) "SIZE(B,1) = ",Size(B,1) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& & write(IPT,*) "SIZE(C,1) = ",Size(C,1) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS + 1 LBUF = NVARS * CM(I)%NRCV CALL MPI_IRECV(RBUF(LP),LBUF,MPI_INTEGER,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:)) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:)) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:)) END IF TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_INTEGER,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS LBUF = CM(LPROC)%NRCV N2 = LP N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_INT_EXCHANGE" RETURN END SUBROUTINE VEC_INT_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE VEC_DBL_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET :: A(:) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:) REAL(DP), POINTER :: AP(:) REAL(DP), POINTER :: BP(:) REAL(DP), POINTER :: CP(:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL VEC_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL VEC_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL VEC_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL VEC_DBL_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE VEC_DBL_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE VEC_DBL_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(DP), INTENT(INOUT), POINTER :: A(:) REAL(DP), INTENT(INOUT), POINTER, OPTIONAL :: B(:) REAL(DP), INTENT(INOUT), POINTER, OPTIONAL :: C(:) INTEGER :: NT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1) = ",Size(A,1) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& & write(IPT,*) "SIZE(B,1) = ",Size(B,1) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& & write(IPT,*) "SIZE(C,1) = ",Size(C,1) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("VEC_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1)) CALL FATAL_ERROR & &("VEC_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS + 1 LBUF = NVARS * CM(I)%NRCV CALL MPI_IRECV(RBUF(LP),LBUF,MPI_DP,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:)) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:)) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:)) END IF TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_DP,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS LBUF = CM(LPROC)%NRCV N2 = LP N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:)) = RBUF(N1:N2) END IF END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_DBL_EXCHANGE" RETURN END SUBROUTINE VEC_DBL_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_FLT_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET :: A(:,:) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:,:) REAL(SPA), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:,:) REAL(SPA), POINTER :: AP(:,:) REAL(SPA), POINTER :: BP(:,:) REAL(SPA), POINTER :: CP(:,:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL ARR_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL ARR_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL ARR_FLT_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL ARR_FLT_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE ARR_FLT_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_FLT_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(SPA), INTENT(INOUT), POINTER :: A(:,:) REAL(SPA), INTENT(INOUT), POINTER, OPTIONAL :: B(:,:) REAL(SPA), INTENT(INOUT), POINTER, OPTIONAL :: C(:,:) INTEGER :: NT,KT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_FLT_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1),Size(A,2) = ",Size(A,1),Size(A,2) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& &write(IPT,*) "SIZE(B,1),Size(B,2) = ",Size(B,1),Size(B,2) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& &write(IPT,*) "SIZE(C,1),Size(C,2) = ",Size(C,1),Size(C,2) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) KT = Size(A,2) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1) .OR. KT .NE. Size(B,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1) .OR. KT .NE. Size(C,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV*KT))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND*KT))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS*KT + 1 LBUF = NVARS * CM(I)%NRCV *KT CALL MPI_IRECV(RBUF(LP),LBUF,MPI_REAL,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*KT*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:),J) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:),J) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:),J) END IF END DO TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_REAL,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*KT*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS*KT LBUF = CM(LPROC)%NRCV N2 = LP DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF END DO END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_FLT_EXCHANGE" RETURN END SUBROUTINE ARR_FLT_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_INT_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET :: A(:,:) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:,:) INTEGER, INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:,:) INTEGER, POINTER :: AP(:,:) INTEGER, POINTER :: BP(:,:) INTEGER, POINTER :: CP(:,:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL ARR_INT_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL ARR_INT_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL ARR_INT_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL ARR_INT_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE ARR_INT_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_INT_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) INTEGER, INTENT(INOUT), POINTER :: A(:,:) INTEGER, INTENT(INOUT), POINTER, OPTIONAL :: B(:,:) INTEGER, INTENT(INOUT), POINTER, OPTIONAL :: C(:,:) INTEGER :: NT,KT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1),Size(A,2) = ",Size(A,1),Size(A,2) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& &write(IPT,*) "SIZE(B,1),Size(B,2) = ",Size(B,1),Size(B,2) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& &write(IPT,*) "SIZE(C,1),Size(C,2) = ",Size(C,1),Size(C,2) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) KT = Size(A,2) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1) .OR. KT .NE. Size(B,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1) .OR. KT .NE. Size(C,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV*KT))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND*KT))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS*KT + 1 LBUF = NVARS * CM(I)%NRCV *KT CALL MPI_IRECV(RBUF(LP),LBUF,MPI_INTEGER,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*KT*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:),J) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:),J) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:),J) END IF END DO TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_INTEGER,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*KT*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS*KT LBUF = CM(LPROC)%NRCV N2 = LP DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF END DO END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_INT_EXCHANGE" RETURN END SUBROUTINE ARR_INT_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_DBL_AEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET :: A(:,:) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: B(:,:) REAL(DP), INTENT(INOUT), ALLOCATABLE, TARGET, OPTIONAL :: C(:,:) REAL(DP), POINTER :: AP(:,:) REAL(DP), POINTER :: BP(:,:) REAL(DP), POINTER :: CP(:,:) IF(ALLOCATED(A)) AP => A IF( PRESENT(B) .AND.PRESENT(C)) THEN IF(ALLOCATED(B)) BP => B IF(ALLOCATED(C)) CP => C CALL ARR_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,BP,CP) ELSE IF(PRESENT(B)) THEN IF(ALLOCATED(B)) BP => B CALL ARR_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,B=BP) ELSE IF(PRESENT(C)) THEN IF(ALLOCATED(C)) CP => C CALL ARR_DBL_PEXCHANGE(CM,MYID,NPROCS,AP,C=CP) ELSE CALL ARR_DBL_PEXCHANGE(CM,MYID,NPROCS,AP) END IF END SUBROUTINE ARR_DBL_AEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE ARR_DBL_PEXCHANGE(CM,MYID,NPROCS,A,B,C) !===================================================================================| ! PASS ELEMENT/NODE INFORMATION AMONG PROCESSORS | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(DP), INTENT(INOUT), POINTER :: A(:,:) REAL(DP), INTENT(INOUT), POINTER, OPTIONAL :: B(:,:) REAL(DP), INTENT(INOUT), POINTER, OPTIONAL :: C(:,:) INTEGER :: NT,KT !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PEXCHANGE" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS IF(ASSOCIATED(A))& &write(IPT,*) "SIZE(A,1),Size(A,2) = ",Size(A,1),Size(A,2) IF(PRESENT(B)) THEN IF(ASSOCIATED(B))& &write(IPT,*) "SIZE(B,1),Size(B,2) = ",Size(B,1),Size(B,2) END IF IF(PRESENT(C)) THEN IF(ASSOCIATED(C))& &write(IPT,*) "SIZE(C,1),Size(C,2) = ",Size(C,1),Size(C,2) END IF DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if IF(.NOT. ASSOCIATED(A)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: PRIMARY ARGUMENT NOT ASSOCIATED") NT = Size(A,1) KT = Size(A,2) IF(PRESENT(B)) THEN IF(.NOT. ASSOCIATED(B)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: SECONDARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(B,1) .OR. KT .NE. Size(B,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION SIZES DO NOT MATCH") END IF IF(PRESENT(C)) THEN IF(.NOT. ASSOCIATED(C)) CALL FATAL_ERROR& &("ARR_FLT_PEXCHANGE: TERTIARY ARGUMENT NOT ASSOCIATED") IF (NT .NE. Size(C,1) .OR. KT .NE. Size(C,2)) CALL FATAL_ERROR & &("ARR_FLT_PEXCHANGE: DIMENSION ARUGEMENTS DO NOT MATCH") END IF NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV*KT))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND*KT))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS*KT + 1 LBUF = NVARS * CM(I)%NRCV *KT CALL MPI_IRECV(RBUF(LP),LBUF,MPI_DP,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*KT*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:),J) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:),J) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:),J) END IF END DO TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_DP,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*KT*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| DO NMSG = 1,TRCV CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS*KT LBUF = CM(LPROC)%NRCV N2 = LP DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) END IF END DO END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_DBL_EXCHANGE" RETURN END SUBROUTINE ARR_DBL_PEXCHANGE !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| SUBROUTINE NODE_MATCH(IMATCH,NBN,BN_MLT,BN_LOC,CM,NT,KT,MYID,NPROCS,A,B,C) !===================================================================================| ! IMATCH=1: ENFORCE AGREEMENT OF A,B,C ON BOUNDARY NODES | ! IMATCH=0: ACCUMULATE VALUES OF A,B,C AT BOUNDARY NODES | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: IMATCH INTEGER, INTENT(IN) :: NBN INTEGER, INTENT(IN) :: BN_MLT(NBN) INTEGER, INTENT(IN) :: BN_LOC(NBN) INTEGER, INTENT(IN) :: NT,KT,MYID,NPROCS TYPE(COMM), INTENT(IN) :: CM(NPROCS) REAL(SP), INTENT(INOUT) :: A(0:NT,KT) REAL(SP), INTENT(INOUT), OPTIONAL :: B(0:NT,KT) REAL(SP), INTENT(INOUT), OPTIONAL :: C(0:NT,KT) !------------------------------------------------------------------------------ LOGICAL :: BYES,CYES INTEGER ::IREQR(NPROCS),IREQS(NPROCS) REAL(SP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),ISTATR(MPI_STATUS_SIZE,NPROCS),IERR,J,N1,N2,NCNT INTEGER I,IFROM,ITO,ISTAG,IRTAG,TRCV,TSND,NVARS,LBUF,LP,NMSG,INDX,LPROC,NSZE !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING NODE_MATCH" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "KT = ",KT write(IPT,*) "SIZE(A,1) = ",Size(A,1) IF(PRESENT(B)) & & write(IPT,*) "SIZE(B,1) = ",Size(B,1) IF(PRESENT(C)) & & write(IPT,*) "SIZE(C,1) = ",Size(C,1) DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "CM(I)%NSND = ",CM(I)%NSND write(IPT,*) "CM(I)%NRCV = ",CM(I)%NRCV END DO write(IPT,*)"===================================" END if NVARS = 1 ; BYES = .FALSE. ; CYES = .FALSE. IF(PRESENT(B)) THEN NVARS = NVARS + 1 BYES = .TRUE. END IF IF(PRESENT(C)) THEN NVARS = NVARS + 1 CYES = .TRUE. END IF ALLOCATE(RBUF(NVARS*SUM(CM(1:NPROCS)%NRCV*KT))) ALLOCATE(SBUF(NVARS*SUM(CM(1:NPROCS)%NSND*KT))) !===================================================================================| ! POST NON-BLOCKING RECEIVES FROM NEIGHBORS | !===================================================================================| TRCV = 0 DO I=1,NPROCS IF(CM(I)%NRCV > 0)THEN IFROM = I-1 IRTAG = I*1000 TRCV = TRCV + 1 LP = CM(I)%RCPT*NVARS*KT + 1 LBUF = NVARS * CM(I)%NRCV *KT CALL MPI_IRECV(RBUF(LP),LBUF,MPI_F,IFROM,IRTAG,MPI_FVCOM_GROUP,IREQR(TRCV),IERR) END IF END DO !===================================================================================| ! SEND DATA TO NEIGHBORS | !===================================================================================| TSND = 0 NCNT = 0 DO I=1,NPROCS LBUF = CM(I)%NSND IF(LBUF > 0)THEN NSZE = LBUF*KT*NVARS ! ALLOCATE(SBUF(NSZE)) N2 = NCNT DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = A(CM(I)%SNDP(:),J) IF(BYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = B(CM(I)%SNDP(:),J) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 SBUF(N1:N2) = C(CM(I)%SNDP(:),J) END IF END DO TSND = TSND + 1 ITO = I-1 ISTAG = MYID*1000 CALL MPI_ISEND(SBUF(NCNT+1),NSZE,MPI_F,ITO,ISTAG,MPI_FVCOM_GROUP,IREQS(TSND),IERR) NCNT = NCNT + LBUF*KT*NVARS ! DEALLOCATE(SBUF) END IF END DO !===================================================================================| ! LOOP OVER PROCS UNTIL A MESSAGE IS RECEIVED AND UNPACK | !===================================================================================| ! DO NMSG = 1,TRCV TRCV = 0 DO LPROC=1,NPROCS IF(CM(LPROC)%NRCV > 0)THEN TRCV = TRCV + 1 CALL MPI_WAIT(IREQR(TRCV),STAT,IERR) ! CALL MPI_WAITANY(TRCV,IREQR,INDX,STAT,IERR) ! LPROC = STAT(MPI_SOURCE) +1 LP = CM(LPROC)%RCPT*NVARS*KT LBUF = CM(LPROC)%NRCV N2 = LP DO J=1,KT N1 = N2+1 ; N2 = N1 + LBUF -1 A(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) + A(CM(LPROC)%RCVP(:),J) IF(BYES)THEN N1 = N2+1; N2 = N1 + LBUF -1 B(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) + B(CM(LPROC)%RCVP(:),J) END IF IF(CYES)THEN N1 = N2+1 ; N2 = N1 + LBUF -1 C(CM(LPROC)%RCVP(:),J) = RBUF(N1:N2) + C(CM(LPROC)%RCVP(:),J) END IF END DO END IF END DO !===================================================================================| ! WAIT FOR COMPLETION OF NON-BLOCKING SENDS | !===================================================================================| CALL MPI_WAITALL(TSND,IREQS,ISTATR,IERR) DEALLOCATE(RBUF,SBUF) !===================================================================================| ! USE MULTIPLICITY OF NODES TO COMPUTE TRUE AVERAGE VALUE | !===================================================================================| IF(IMATCH /=1)RETURN DO J=1,KT DO I=1,NBN A( BN_LOC(I),J) = A( BN_LOC(I),J)/FLOAT(BN_MLT(I)) IF(BYES)B( BN_LOC(I),J) = B( BN_LOC(I),J)/FLOAT(BN_MLT(I)) IF(CYES)C( BN_LOC(I),J) = C( BN_LOC(I),J)/FLOAT(BN_MLT(I)) END DO END DO if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END NODE_MATCH" RETURN END SUBROUTINE NODE_MATCH !===================================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: !===================================================================================| SUBROUTINE VEC_INT_ADEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A VECTOR of INTEGERS FROM A GLOBAL VECTOR | ! INTO LOCAL VECTORS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:) :: AP INTEGER, POINTER,DIMENSION(:) :: AGP INTEGER, ALLOCATABLE,TARGET,DIMENSION(:) :: A INTEGER, ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_INT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE VEC_INT_ADEAL !===================================================================================| SUBROUTINE VEC_INT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A VECTOR of INTEGERS FROM A GLOBAL VECTOR | ! INTO LOCAL VECTORS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:) :: A INTEGER, POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30111 ! UNIQUE TAG FOR VEC_INT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "Ubound(A,1) = ",Ubound(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "Ubound(AG,1) = ",Ubound(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: VEC_INT_PDEAL") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_INT_PDEAL") if (NSZE == 0) CYCLE if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_INT_PDEAL") if(Ubound(A,1) < LSZE) & ! ALLOW FOR M index into MT array & CALL FATAL_ERROR("DEALER POINTER (A) UBOUND DOES NOT MATCH MAP: VEC_INT_PDEAL") DO I=1,NSZE A(GM(IP)%LOC_2_Grid(I)) = AG(GM(IP)%LOC_2_GL(I)) END DO else ALLOCATE(SBUF(NSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("DEALER CAN NOT ALLOCATE MEMORY IN VEC_INT_PDEAL") DO I=1,NSZE SBUF(I) = AG(GM(IP)%LOC_2_GL(I)) END DO DEST = IP - 1 CALL MPI_SEND(SBUF,NSZE,MPI_INTEGER,DEST,TAG,MPI_FVCOM_GROUP,IERR) IF (IERR /= 0) CALL FATAL_ERROR("Send Error in VEC_INT_PDEAL") DEALLOCATE(SBUF,STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("DEALER CAN NOT DEALLOCATE MEMORY IN VEC_INT_PDEAL") end if END DO else ! IF I AM ONE OF THE RECEIVERS SOURCE = SENDID - 1 NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (NSZE == 0 ) RETURN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_INT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:) :: A INTEGER, POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30111 ! UNIQUE TAG FOR VEC_INT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: VEC_INT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "Ubound(A,1) = ",Ubound(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "Ubound(AG,1) = ",Ubound(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: VEC_INT_PDEAL_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_INT_PDEAL_IO") if (NSZE == 0) CYCLE if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_INT_PDEAL_IO") if(Ubound(A,1) < LSZE) & ! ALLOW FOR M index into MT array & CALL FATAL_ERROR("DEALER POINTER (A) UBOUND DOES NOT MATCH MAP: VEC_INT_PDEAL_IO") DO I=1,NSZE A(GM(NIO_LIST(IP))%LOC_2_Grid(I)) = AG(GM(NIO_LIST(IP))%LOC_2_GL(I)) END DO else ALLOCATE(SBUF(NSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("DEALER CAN NOT ALLOCATE MEMORY IN VEC_INT_PDEAL_IO") DO I=1,NSZE SBUF(I) = AG(GM(NIO_LIST(IP))%LOC_2_GL(I)) END DO DEST = IP - 1 CALL MPI_SEND(SBUF,NSZE,MPI_INTEGER,DEST,TAG,MPI_io_group,IERR) IF (IERR /= 0) CALL FATAL_ERROR("Send Error in VEC_INT_PDEAL_IO") DEALLOCATE(SBUF,STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("DEALER CAN NOT DEALLOCATE MEMORY IN VEC_INT_PDEAL_IO") end if END DO else ! IF I AM ONE OF THE RECEIVERS SOURCE = SENDID - 1 NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (NSZE == 0 ) RETURN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_INT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: A INTEGER, ALLOCATABLE,TARGET,DIMENSION(:) :: AG INTEGER, POINTER,DIMENSION(:) :: AP INTEGER, POINTER,DIMENSION(:) :: AGP IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE VEC_INT_ACOLLECT !===================================================================================| SUBROUTINE VEC_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF INTEGERS FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30112 ! UNIQUE TAG FOR VEC_INT_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_INT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:),SZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,IP,DEST,SOURCE,NSZE,LSZE,GSZE,SZE_total INTEGER, PARAMETER :: TAG = 30112 ! UNIQUE TAG FOR VEC_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1)0) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I) = A(GM(MYID)%LOC_2_GRID(I)) END DO else ALLOCATE(SBUF(1),STAT=IERR) SBUF(1)=0 ENDIF CALL MPI_gatherv(SBUF,NSZE, MPI_INTEGER,RBUF,SZE_list,displs,MPI_INTEGER,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO I=1,SZE_list(IP) AG(GM(NIO_LIST(IP))%LOC_2_GL(I)) = RBUF(I+displs(IP)) ENDDO ENDDO ENDIF DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_INT_PCOLLECT_IO" END SUBROUTINE VEC_INT_PCOLLECT_IO SUBROUTINE VEC_INT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF INTEGERS FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30112 ! UNIQUE TAG FOR VEC_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:) :: AP INTEGER, POINTER,DIMENSION(:,:) :: AGP INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:) :: A INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_INT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE ARR_INT_ADEAL !===================================================================================| SUBROUTINE ARR_INT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of INTEGERS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:) :: A INTEGER, POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30121 ! UNIQUE TAG FOR ARR_INT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_INT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_INT_PDEAL") PSZE=ubound(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_INT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_INT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:) :: A INTEGER, POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30121 ! UNIQUE TAG FOR ARR_INT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_INT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_INT_PDEAL_IO") PSZE=ubound(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_INT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_INT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:) :: AP INTEGER, POINTER,DIMENSION(:,:) :: AGP INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:),INTENT(IN) :: A INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE ARR_INT_ACOLLECT !===================================================================================| SUBROUTINE ARR_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:),SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30122 ! UNIQUE TAG FOR ARR_INT_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_INT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:,:),SZE_list(:),PSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE,SZE_total,Y INTEGER, PARAMETER :: TAG = 30122 ! UNIQUE TAG FOR ARR_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE IF (MYID_iogroup .EQ. RECVID) then IF(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) IF(NSZE > 0 ) THEN IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") IF(Ubound(A,1)0) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE) END DO else ALLOCATE(SBUF(1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE, MPI_INTEGER,RBUF,SZE_list,displs,MPI_INTEGER,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J) = RBUF(I+Y+displs(IP)) END DO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_INT_PCOLLECT_IO" END SUBROUTINE ARR_INT_PCOLLECT_IO !===================================================================================| SUBROUTINE ARR_INT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:),SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30122 ! UNIQUE TAG FOR ARR_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:) :: AP INTEGER, POINTER,DIMENSION(:,:,:) :: AGP INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:,:) :: A INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_INT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE CUB_INT_ADEAL !===================================================================================| SUBROUTINE CUB_INT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of INTEGERS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:) :: A INTEGER, POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30131 ! UNIQUE TAG FOR ARR_INT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_INT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_INT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& & ("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_INT_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_INT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_INT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:) :: A INTEGER, POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30131 ! UNIQUE TAG CUB_INT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_INT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_INT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& & ("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_INT_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_INT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_INT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:) :: AP INTEGER, POINTER,DIMENSION(:,:,:) :: AGP INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:,:),INTENT(IN) :: A INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE CUB_INT_ACOLLECT !===================================================================================| SUBROUTINE CUB_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR CUB_INT_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_INT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_INT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:,:,:),SZE_list(:),PSZE_list(:),QSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE,SZE_total,Y,Z INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR CUB_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) IF (NSZE > 0) then IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") IF(Ubound(A,1) 0) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN CUB_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE) END DO else ALLOCATE(SBUF(1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE, MPI_INTEGER,RBUF,SZE_list,displs,MPI_INTEGER,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K) = RBUF(I+Y+Z+displs(IP)) END DO ENDDO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END CUB_INT_PCOLLECT_IO" END SUBROUTINE CUB_INT_PCOLLECT_IO !===================================================================================| SUBROUTINE CUB_INT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR CUB_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:) :: AP INTEGER, POINTER,DIMENSION(:,:,:,:) :: AGP INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:,:,:) :: A INTEGER, ALLOCATABLE, TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_INT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE FDA_INT_ADEAL !===================================================================================| SUBROUTINE FDA_INT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of INTEGERS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:) :: A INTEGER, POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30131 ! UNIQUE TAG FOR ARR_INT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_INT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_INT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& & ("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_INT_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_INT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_INT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:) :: A INTEGER, POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30131 ! UNIQUE TAG FOR FDA_INT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_INT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_INT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& & ("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_INT_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_INT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_INT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:) :: AP INTEGER, POINTER,DIMENSION(:,:,:,:) :: AGP INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: A INTEGER, ALLOCATABLE,TARGET,DIMENSION(:,:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE FDA_INT_ACOLLECT !===================================================================================| SUBROUTINE FDA_INT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR FDA_INT_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_INT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_INT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:),SBUF(:,:,:,:),SZE_list(:),PSZE_list(:),QSZE_list(:),RSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,L,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE,SZE_total,Y,Z,H INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR FDA_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) IF( NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE,RSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE,1:RSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE,1:RSZE) END DO else ALLOCATE(SBUF(1,1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE*RSZE, MPI_INTEGER,RBUF,SZE_list,displs,MPI_INTEGER,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO L=1,RSZE_list(IP) H=(L-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP)*QSZE_list(IP) DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K,L) = RBUF(I+Y+Z+H+displs(IP)) END DO ENDDO ENDDO ENDDO ENDDO DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(RSZE_list) ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(RSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END FDA_INT_PCOLLECT_IO" END SUBROUTINE FDA_INT_PCOLLECT_IO !===================================================================================| SUBROUTINE FDA_INT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) INTEGER, POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A INTEGER, POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ INTEGER, ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30132 ! UNIQUE TAG FOR FDA_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:) :: AP REAL(SPA), POINTER,DIMENSION(:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE VEC_FLT_ADEAL !===================================================================================| SUBROUTINE VEC_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A VECTOR of REALS FROM A GLOBAL VECTOR | ! INTO LOCAL VECTORS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:) :: A REAL(SPA), POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30211 ! UNIQUE TAG FOR VEC_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: VEC_FLT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST ASSOCIATED FOR THE DEALER: VEC_FLT_PDEAL") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_FLT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:) :: A REAL(SPA), POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30211 ! UNIQUE TAG FOR VEC_FLT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: VEC_FLT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG)) CALL FATAL_ERROR& &("POINTER (AG) PASSED TO DEAL MUST ASSOCIATED FOR THE DEALER: VEC_FLT_PDEAL_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_FLT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_FLT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:) :: AP REAL(SPA), POINTER,DIMENSION(:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE VEC_FLT_ACOLLECT !===================================================================================| SUBROUTINE VEC_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF REALS FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30212 ! UNIQUE TAG FOR VEC_FLT_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_FLT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_FLT_PCOLLECT") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_FLT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER, ALLOCATABLE :: SZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,IP,DEST,SOURCE,NSZE,LSZE,GSZE,SZE_total INTEGER, PARAMETER :: TAG = 30212 ! UNIQUE TAG FOR VEC_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I) = A(GM(MYID)%LOC_2_GRID(I)) END DO else ALLOCATE(SBUF(1),STAT=IERR) SBUF(1)=0 ENDIF CALL MPI_gatherv(SBUF,NSZE, MPI_REAL,RBUF,SZE_list,displs,MPI_REAL,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO I=1,SZE_list(IP) AG(GM(NIO_LIST(IP))%LOC_2_GL(I)) = RBUF(I+displs(IP)) END DO ENDDO ENDIF DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_FLT_PCOLLECT_IO" END SUBROUTINE VEC_FLT_PCOLLECT_IO !===================================================================================| SUBROUTINE VEC_FLT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF REALS FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30212 ! UNIQUE TAG FOR VEC_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_FLT_PCOLLECT_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_FLT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE ARR_FLT_ADEAL !===================================================================================| SUBROUTINE ARR_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of REALS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30221 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_FLT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_FLT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_FLT_PDEAL") PSZE=ubound(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A)) CALL FATAL_ERROR& &("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_FLT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30221 ! UNIQUE TAG FOR ARR_FLT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_FLT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_FLT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_FLT_PDEAL_IO") PSZE=ubound(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_FLT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A)) CALL FATAL_ERROR& &("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_FLT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:),INTENT(IN) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE ARR_FLT_ACOLLECT !===================================================================================| SUBROUTINE ARR_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF REALS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:),SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30222 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_FLT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_FLT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_FLT_PCOLLECT") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_FLT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE,SZE_total,Y INTEGER, PARAMETER :: TAG = 30222 ! UNIQUE TAG FOR ARR_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE IF (MYID_iogroup .EQ. RECVID) then IF(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) IF(NSZE > 0 ) THEN IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") IF(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE) END DO else ALLOCATE(SBUF(1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE, MPI_REAL,RBUF,SZE_list,displs,MPI_REAL,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J) = RBUF(I+Y+displs(IP)) END DO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_FLT_PCOLLECT_IO" END SUBROUTINE ARR_FLT_PCOLLECT_IO !===================================================================================| SUBROUTINE ARR_FLT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF INTEGERS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:),SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30122 ! UNIQUE TAG FOR ARR_INT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_INT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_INT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE CUB_FLT_ADEAL !===================================================================================| SUBROUTINE CUB_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of REALS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30231 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_FLT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_FLT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_FLT_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_FLT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30231 ! UNIQUE TAG FOR CUB_FLT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_FLT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_FLT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_FLT_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_FLT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_FLT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:),INTENT(IN) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE CUB_FLT_ACOLLECT !===================================================================================| SUBROUTINE CUB_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF REALS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_FLT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_FLT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_FLT_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_FLT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:,:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),QSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE,SZE_total,Y,Z INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR CUB_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) IF (NSZE > 0) then IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") IF(Ubound(A,1) 0) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE) END DO else ALLOCATE(SBUF(1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE, MPI_REAL,RBUF,SZE_list,displs,MPI_REAL,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K) = RBUF(I+Y+Z+displs(IP)) END DO ENDDO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END CUB_FLT_PCOLLECT_IO" END SUBROUTINE CUB_FLT_PCOLLECT_IO !===================================================================================| SUBROUTINE CUB_FLT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF REALS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR CUB_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_FLT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_FLT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE FDA_FLT_ADEAL !===================================================================================| SUBROUTINE FDA_FLT_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of REALS FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30231 ! UNIQUE TAG FOR FDA_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_FLT_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_FLT_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_FLT_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_FLT_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: A REAL(SPA), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30231 ! UNIQUE TAG FOR FDA_FLT_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_FLT_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_FLT_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_FLT_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_FLT_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_FLT_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AP REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AGP REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(SPA), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE FDA_FLT_ACOLLECT !===================================================================================| SUBROUTINE FDA_FLT_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF REALS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_FLT_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_FLT_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_FLT_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_FLT_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:),SBUF(:,:,:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),QSZE_list(:),RSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,L,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE,SZE_total,Y,Z,H INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR FDA_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) IF( NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE,RSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE,1:RSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE,1:RSZE) END DO else ALLOCATE(SBUF(1,1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE*RSZE, MPI_REAL,RBUF,SZE_list,displs,MPI_REAL,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO L=1,RSZE_list(IP) H=(L-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP)*QSZE_list(IP) DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K,L) = RBUF(I+Y+Z+H+displs(IP)) END DO ENDDO ENDDO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(RSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END FDA_FLT_PCOLLECT_IO" END SUBROUTINE FDA_FLT_PCOLLECT_IO !===================================================================================| SUBROUTINE FDA_FLT_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF REALS FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(SPA), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(SPA), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(SPA), ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30232 ! UNIQUE TAG FOR FDA_FLT_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_FLT_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_FLT_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_FLT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_FLT_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:) :: AP REAL(DP), POINTER,DIMENSION(:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE VEC_DBL_ADEAL !===================================================================================| SUBROUTINE VEC_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A VECTOR of DOUBLES FROM A GLOBAL VECTOR | ! INTO LOCAL VECTORS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:) :: A REAL(DP), POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30311 ! UNIQUE TAG FOR VEC_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: VEC_DBL_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST ALREADY BE ASSOCIATED: VEC_DBL_PDEAL") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_DBL_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_DBL_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:) :: A REAL(DP), POINTER,DIMENSION(:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:),RBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30311 ! UNIQUE TAG FOR VEC_DBL_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: VEC_DBL_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1) = ",UBOUND(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1) = ",UBOUND(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST ALREADY BE ASSOCIATED: VEC_DBL_PDEAL_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN VEC_DBL_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: VEC_DBL_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:) :: AP REAL(DP), POINTER,DIMENSION(:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:),INTENT(IN) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL VEC_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE VEC_DBL_ACOLLECT !===================================================================================| SUBROUTINE VEC_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF DOUBLES FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30312 ! UNIQUE TAG FOR VEC_DBL_PCOLLECT !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_DBL_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "Ubound(A,1) = ",Ubound(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "Ubound(AG,1) = ",Ubound(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_DBL_PCOLLECT") DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_DBL_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER, ALLOCATABLE :: SZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,IP,DEST,SOURCE,NSZE,LSZE,GSZE,SZE_total INTEGER, PARAMETER :: TAG = 30312 ! UNIQUE TAG FOR VEC_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "Ubound(A,1) = ",Ubound(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "Ubound(AG,1) = ",Ubound(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I) = A(GM(MYID)%LOC_2_GRID(I)) END DO else ALLOCATE(SBUF(1),STAT=IERR) SBUF(1)=0 ENDIF CALL MPI_gatherv(SBUF,NSZE, MPI_DP,RBUF,SZE_list,displs,MPI_DP,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO I=1,SZE_list(IP) AG(GM(NIO_LIST(IP))%LOC_2_GL(I)) = RBUF(I+displs(IP)) END DO ENDDO ENDIF DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END VEC_DBL_PCOLLECT_IO" END SUBROUTINE VEC_DBL_PCOLLECT_IO !===================================================================================| SUBROUTINE VEC_DBL_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT A VECTOR OF DOUBLES FROM LOCAL VECTORS | ! INTO A GLOBAL VECTOR A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30312 ! UNIQUE TAG FOR VEC_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING VEC_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL COLLECT AS THE RECEIVER: VEC_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "Ubound(A,1) = ",Ubound(A,1) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "Ubound(AG,1) = ",Ubound(AG,1) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"=============MAP INFO==============" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID) = ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: VEC_DBL_PCOLLECT_IO") DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: VEC_DBL_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE ARR_DBL_ADEAL !===================================================================================| SUBROUTINE ARR_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of DOUBLES FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:) :: A REAL(DP), POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30321 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_DBL_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_DBL_PDEAL") PSZE=size(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_DBL_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:) :: A REAL(DP), POINTER,DIMENSION(:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:),RBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30321 ! UNIQUE TAG FOR ARR_DBL_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: ARR_DBL_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: ARR_DBL_PDEAL_IO") PSZE=size(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("THE GLOBAL ARRAY UBOUND DOES NOT MATCH THE MAP IN ARR_FLT_PDEAL") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: ARR_DBL_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:),INTENT(IN) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL ARR_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE ARR_DBL_ACOLLECT !===================================================================================| SUBROUTINE ARR_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:), SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30322 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_DBL_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_DBL_PCOLLECT") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_DBL_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:), SBUF(:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE,SZE_total,Y INTEGER, PARAMETER :: TAG = 30322 ! UNIQUE TAG FOR ARR_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE IF (MYID_iogroup .EQ. RECVID) then IF(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) IF(NSZE > 0 ) THEN IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") IF(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE) END DO else ALLOCATE(SBUF(1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE, MPI_DP,RBUF,SZE_list,displs,MPI_DP,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J) = RBUF(I+Y+displs(IP)) END DO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END ARR_DBL_PCOLLECT_IO" END SUBROUTINE ARR_DBL_PCOLLECT_IO !===================================================================================| SUBROUTINE ARR_DBL_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:), SBUF(:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30322 ! UNIQUE TAG FOR ARR_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING ARR_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: ARR_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2)= ",UBOUND(A,1),UBOUND(A,2) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1), UBOUND(AG,2)= ",UBOUND(AG,1),UBOUND(AG,2) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: ARR_DBL_PCOLLECT_IO") PSZE = UBOUND(AG,2) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: ARR_DBL_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE CUB_DBL_ADEAL !===================================================================================| SUBROUTINE CUB_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of DOUBLES FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:) :: A REAL(DP), POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30331 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_DBL_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_DBL_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_DBL_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_DBL_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_DBL_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:) :: A REAL(DP), POINTER,DIMENSION(:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:,:),RBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30331 ! UNIQUE TAG FOR CUB_DBL_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_DBL_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: CUB_DBL_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: CUB_DBL_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: CUB_DBL_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: CUB_DBL_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:),INTENT(IN) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL CUB_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE CUB_DBL_ACOLLECT !===================================================================================| SUBROUTINE CUB_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR CUB_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_DBL_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_DBL_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_DBL_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_DBL_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:,:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),QSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE,SZE_total,Y,Z INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR CUB_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) IF (NSZE > 0) then IF(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") IF(Ubound(A,1) 0) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE) END DO else ALLOCATE(SBUF(1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE, MPI_DP,RBUF,SZE_list,displs,MPI_DP,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K) = RBUF(I+Y+Z+displs(IP)) END DO ENDDO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END CUB_DBL_PCOLLECT_IO" END SUBROUTINE CUB_DBL_PCOLLECT_IO !===================================================================================| SUBROUTINE CUB_DBL_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:,:),SBUF(:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR CUB_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING CUB_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: CUB_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: CUB_DBL_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: CUB_DBL_PCOLLECT_IO") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AGP,AP) END SUBROUTINE FDA_DBL_ADEAL !===================================================================================| SUBROUTINE FDA_DBL_PDEAL(MYID,SENDID,NPROCS,GM,AG,A) !===================================================================================| ! DEAL A ARRAY of DOUBLES FROM A GLOBAL ARRAY | ! INTO LOCAL ARRAYS AG(0:NTG) --> A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:) :: A REAL(DP), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30331 ! UNIQUE TAG FOR ARR_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_DBL_PDEAL" if((MYID .GT. NPROCS) .AND. (MYID .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_DBL_PDEAL") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_DBL_PDEAL") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_DBL_PDEAL") if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_DBL_PDEAL") if(Ubound(A,1) A(0:NT) BY MAPPING GM | ! UPON COMPLETION EACH PROCESSOR HAS A | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE control, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,SENDID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:) :: A REAL(DP), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: SBUF(:,:,:,:),RBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30331 ! UNIQUE TAG FOR FDA_DBL_PDEAL_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_DBL_PDEAL_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. SENDID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE SENDER: FDA_DBL_PDEAL_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "SENDID = ",SENDID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. SENDID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO DEAL MUST BE ASSOCIATED FOR THE DEALER: FDA_DBL_PDEAL_IO") PSZE=UBOUND(AG,2) QSZE=UBOUND(AG,3) RSZE=UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE IF(UBOUND(AG,1) .NE. GSZE) CALL FATAL_ERROR& &("The global array ubound does not match the map: FDA_DBL_PDEAL_IO") if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM DEAL MUST ALREADY BE ASSOCIATED: FDA_DBL_PDEAL_IO") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AP REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AGP REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(DP), ALLOCATABLE,TARGET,DIMENSION(:,:,:,:) :: AG IF(ALLOCATED(A)) AP => A IF(ALLOCATED(AG)) AGP => AG CALL FDA_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,AP,AGP) END SUBROUTINE FDA_DBL_ACOLLECT !===================================================================================| SUBROUTINE FDA_DBL_PCOLLECT(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR CUB_FLT_PDEAL !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_DBL_PCOLLECT" if((MYID .GT. NPROCS) .AND. (MYID .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_DBL_PCOLLECT") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_DBL_PCOLLECT") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS NSZE = GM(IP)%NSIZE LSZE = GM(IP)%LSIZE GSZE = GM(IP)%GSIZE if (NSZE == 0) cycle if (IP == MYID) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_DBL_PCOLLECT") if(Ubound(A,1) AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:),SBUF(:,:,:,:) INTEGER, ALLOCATABLE :: SZE_list(:),PSZE_list(:),QSZE_list(:),RSZE_list(:),displs(:) INTEGER STAT(MPI_STATUS_SIZE),IERR INTEGER I,J,K,L,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE,SZE_total,Y,Z,H INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR FDA_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if NSZE = GM(MYID)%NSIZE LSZE = GM(MYID)%LSIZE GSZE = GM(MYID)%GSIZE if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) IF( NSZE > 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1) 0 ) THEN if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_INT_PCOLLECT_IO") if(Ubound(A,1)0) then ALLOCATE(SBUF(NSZE,PSZE,QSZE,RSZE),STAT=IERR) if (IERR /= 0) CALL FATAL_ERROR("SENDER CAN NOT ALLOCATE MEMORY IN VEC_INT_PCOLLECT_IO") DO I=1,NSZE SBUF(I,1:PSZE,1:QSZE,1:RSZE) = A(GM(MYID)%LOC_2_GRID(I),1:PSZE,1:QSZE,1:RSZE) END DO else ALLOCATE(SBUF(1,1,1,1),STAT=IERR) SBUF=0 ENDIF CALL MPI_gatherv(SBUF,NSZE*PSZE*QSZE*RSZE, MPI_DP,RBUF,SZE_list,displs,MPI_DP,RECVID-1,MPI_io_group,ierr) DEALLOCATE(SBUF) IF(MYID_iogroup .EQ. RECVID) then DO IP=1,NPROCS_io DO L=1,RSZE_list(IP) H=(L-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP)*QSZE_list(IP) DO K=1,QSZE_list(IP) Z=(K-1)*GM(NIO_LIST(IP))%NSIZE*PSZE_list(IP) DO J=1,PSZE_list(IP) Y=(J-1)*GM(NIO_LIST(IP))%NSIZE DO I=1,GM(NIO_LIST(IP))%NSIZE AG(GM(NIO_LIST(IP))%LOC_2_GL(I),J,K,L) = RBUF(I+Y+Z+H+displs(IP)) END DO ENDDO ENDDO ENDDO ENDDO ENDIF DEALLOCATE(PSZE_list) DEALLOCATE(QSZE_list) DEALLOCATE(RSZE_list) DEALLOCATE(SZE_list) DEALLOCATE(displs) DEALLOCATE(RBUF) if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END FDA_DBL_PCOLLECT_IO" END SUBROUTINE FDA_DBL_PCOLLECT_IO !===================================================================================| SUBROUTINE FDA_DBL_PCOLLECT_IO_bak(MYID,RECVID,NPROCS,GM,A,AG) !===================================================================================| ! COLLECT AN ARRAY OF DOUBLES FROM A LOCAL ARRAYS | ! INTO A GLOBAL ARRAY A(0:NT) --> AG(0:NTG) BY MAPPING GM | ! UPON COMPLETION ONE PROCESSOR HAS AG | !===================================================================================| USE LIMS, ONLY : NIO_LIST,MYID_iogroup,NPROCS_io USE CONTROL, only : MPI_io_group IMPLICIT NONE !------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: MYID,RECVID,NPROCS TYPE(MAP), INTENT(IN) :: GM(NPROCS) REAL(DP), POINTER,DIMENSION(:,:,:,:),INTENT(IN) :: A REAL(DP), POINTER,DIMENSION(:,:,:,:) :: AG !------------------------------------------------------------------------------ REAL(DP), ALLOCATABLE :: RBUF(:,:,:,:),SBUF(:,:,:,:) INTEGER STAT(MPI_STATUS_SIZE),IERR,I,IP,DEST,SOURCE,NSZE,PSZE,QSZE,RSZE,LSZE,GSZE INTEGER, PARAMETER :: TAG = 30332 ! UNIQUE TAG FOR FDA_DBL_PCOLLECT_IO !------------------------------------------------------------------------------ if(DBG_SET(dbg_sbr)) & & write(IPT,*) "STARTING FDA_DBL_PCOLLECT_IO" if((MYID_iogroup .GT. NPROCS_io) .AND. (MYID_iogroup .NE. RECVID) )& & CALL FATAL_ERROR("IOPROC CAN ONLY CALL DEAL AS THE RECEIVER: FDA_DBL_PCOLLECT_IO") if(DBG_SET(dbg_sbrio)) then write(IPT,*) "MYID = ",MYID write(IPT,*) "NPROCS = ",NPROCS write(IPT,*) "RECVID = ",RECVID if(associated(A)) then write(IPT,*) "UBOUND(A,1), UBOUND(A,2), UBOUND(A,3), UBOUND(A,4) = ",UBOUND(A,1),UBOUND(A,2),UBOUND(A,3),UBOUND(A,4) else write(IPT,*) "A is not associated" end if if(associated(AG)) then write(IPT,*) "UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) = ",UBOUND(AG,1),UBOUND(AG,2),UBOUND(AG,3),UBOUND(AG,4) else write(IPT,*) "AG is not associated" end if DO I = 1,NPROCS write(IPT,*)"===================================" write(IPT,*) "ID = ",I write(IPT,*) "GM(I)%NSIZE = ",GM(I)%NSIZE write(IPT,*) "GM(I)%LSIZE = ",GM(I)%LSIZE write(IPT,*) "GM(I)%GSIZE = ",GM(I)%GSIZE write(IPT,*) "UBOUND(GM(I)%LOC_2_GL) = ",UBOUND(GM(I)%LOC_2_GL) if(associated(GM(I)%LOC_2_GRID)) write(IPT,*) "UBOUND(GM(I)%LOC_2_GRID)= ",UBOUND(GM(I)%LOC_2_GRID) END DO write(IPT,*)"===================================" END if if (MYID_iogroup .EQ. RECVID) then if(.not. associated(AG))& & CALL FATAL_ERROR("POINTER (AG) PASSED TO COLELCT MUST ALREADY BE ASSOCIATED: FDA_DBL_PCOLLECT_IO") PSZE = UBOUND(AG,2) QSZE = UBOUND(AG,3) RSZE = UBOUND(AG,4) DO IP = 1 , NPROCS_io NSZE = GM(NIO_LIST(IP))%NSIZE LSZE = GM(NIO_LIST(IP))%LSIZE GSZE = GM(NIO_LIST(IP))%GSIZE if (NSZE == 0) cycle if (IP == MYID_iogroup) then if(.not. associated(A))& & CALL FATAL_ERROR("POINTER (A) RETURNED FROM COLLECT MUST ALREADY BE ASSOCIATED: FDA_DBL_PCOLLECT_IO") if(Ubound(A,1) LAST) M(I) = J(1) LAST = N(J(1)) END DO RETURN END SUBROUTINE SORT !===================================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: INTEGER FUNCTION GETLOC(GLOC,MAP,N) !===================================================================================| ! DETERMINE LOCAL IDENTITY OF ELEMENT/NODE I USING MAP | !===================================================================================| !------------------------------------------------------------------------------ IMPLICIT NONE INTEGER, INTENT(IN) :: GLOC,N INTEGER, INTENT(IN) :: MAP(N) INTEGER I,FOUND !------------------------------------------------------------------------------ FOUND = 0 DO I=1,N IF(MAP(I)==GLOC) FOUND = I END DO GETLOC = FOUND RETURN END FUNCTION GETLOC !===================================================================================| !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: !==============================================================================| SUBROUTINE ADD_MAP2LIST(HEAD,MP) IMPLICIT NONE TYPE(MAPLINK), target :: HEAD TYPE(MAP),POINTER ::MP(:) TYPE(MAPLINK), POINTER :: current, previous integer CNT CNT = 1 previous => HEAD current => previous%next DO IF(.NOT. ASSOCIATED(CURRENT)) EXIT CURRENT => CURRENT%NEXT PREVIOUS => PREVIOUS%NEXT CNT = CNT +1 IF(CNT > 100) CALL FATAL_ERROR& &("ADD_MAP_TO_LIST: LOOP COUNT EXCEEDED 100; STOP!") END DO allocate(previous%next) previous%next%next =>current previous%next%MAP => MP END SUBROUTINE ADD_MAP2LIST !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| ! MAKE A GLOBAL COLLECT/DEAL MAP AND EXCHANGE TO ALL PROCS !===================================================================================| FUNCTION MAKE_MAP(MYID,NPROCS,GSIZE,LSIZE,N2G,N2L) RESULT(MYMAP) ! BECAUSE THE HALO IS AT THE END OF THE ARRAY, THERE IS NO NEED ! FOR AN EXPLICIT LOCAL MAP. THE DATA ARRAY SENT IN THE MPI CALL ! IS ONE TO ONE WITH DATA IN THE LOCAL ARRAY. MAKE_MAP ACCEPTS A ! LOCAL INDEX ARRAY THAT MAPS THE DATA SENT IN THE MPI CALL TO THE ! LOCAL ARRAY FOR MORE COMPLEX CASES, I.E. SUBDOMAINS. USE LIMS, only : NPROCS_TOTAL,NPROCS_FVCOM USE CONTROL, ONLY : MPI_COMM_FVCOM IMPLICIT NONE TYPE(MAP), POINTER, DIMENSION(:) :: MYMAP INTEGER,INTENT(IN) :: MYID,NPROCS,GSIZE,LSIZE INTEGER, POINTER :: N2G(:) INTEGER, OPTIONAL, POINTER :: N2L(:) INTEGER, POINTER :: TEMP(:) INTEGER :: I, J, SENDER,IERR,NSIZE if(DBG_SET(dbg_sbr)) & & write(IPT,*) "START MAKE_MAP" if(DBG_SET(dbg_sbrio)) then write(IPT,*) "myid",myid write(IPT,*) "nprocs",nprocs write(IPT,*) "gsize",gsize write(IPT,*) "lsize",lsize write(IPT,*) "N2G-UBOUND",UBOUND(N2G,1) IF(PRESENT(N2L)) THEN write(IPT,*) "N2L-UBOUND",UBOUND(N2L,1) END if end if !!$ ALLOCATE(MYMAP(NPROCS)) ALLOCATE(MYMAP(NPROCS_total)) ! MAKE SAFE FOR ALLGATHER USING MPI_IO_MODE !!$ ALLOCATE(TEMP(NPROCS+1)) ALLOCATE(TEMP(NPROCS_TOTAL)) MYMAP(:)%NSIZE = 0 MYMAP(:)%GSIZE = GSIZE MYMAP(:)%LSIZE = 0 NSIZE = 0 IF(associated(N2G)) NSIZE = UBOUND(N2G,1) !--Determine Number of Elements for Each Processor CALL MPI_ALLGATHER(NSIZE,1,MPI_INTEGER,TEMP,1,MPI_INTEGER,MPI_COMM_FVCOM,ierr) MYMAP(:)%NSIZE = TEMP(1:NPROCS) !!$ DO I=1,NPROCS !!$ IF(MYID == I) MYMAP(I)%NSIZE = NSIZE !!$ SENDER = I - 1 !!$ CALL MPI_BCAST(MYMAP(I)%NSIZE,1,MPI_INTEGER,SENDER,MPI_COMM_FVCOM,IERR) !!$ END DO IF(NSIZE > LSIZE) CALL FATAL_ERROR & &("MAKE_MAP: WHEN CREATING AN MPI MAP TYPE IF THERE IS NO LOCAL_2_GRID INDEX",& & "THEN THE Local Size MUST BE GREATER THAN NSIZE, THE UBOUND OF N2G INDEX ARRAY") ! MAP IS ONE TO ONE SO THE LOCAL SIZE IS THE SAME AS THE LOCAL DATA SIZE CALL MPI_ALLGATHER(LSIZE,1,MPI_INTEGER,TEMP,1,MPI_INTEGER,MPI_COMM_FVCOM,ierr) MYMAP(:)%LSIZE = TEMP(1:NPROCS) !!$ DO I=1,NPROCS !!$ IF(MYID == I) MYMAP(I)%LSIZE = LSIZE !!$ SENDER = I - 1 !!$ CALL MPI_BCAST(MYMAP(I)%LSIZE,1,MPI_INTEGER,SENDER,MPI_COMM_FVCOM,IERR) !!$ END DO !--Construct Mapping Array for Each Processor DO I=1,NPROCS NSIZE = MYMAP(I)%NSIZE IF(NSIZE > 0) THEN ALLOCATE(MYMAP(I)%LOC_2_GL(0:NSIZE)) MYMAP(I)%LOC_2_GL=0 if(myid == I) MYMAP(I)%LOC_2_GL(1:NSIZE) = N2G(1:NSIZE) SENDER = I - 1 CALL MPI_BCAST(MYMAP(I)%LOC_2_GL(1:NSIZE),NSIZE,MPI_INTEGER,SENDER,MPI_COMM_FVCOM,IERR) ELSE NULLIFY(MYMAP(I)%LOC_2_GL) END IF NULLIFY(MYMAP(I)%LOC_2_GRID) END DO ! THIS ARRAY IS ONLY NEEDED ON THE LOCAL PROCESSOR - DO NOT USE ! MPI TO BROADCAST IT! NSIZE = 0 IF(MYID <= NPROCS) NSIZE = MYMAP(MYID)%NSIZE IF(NSIZE > 0) THEN IF(PRESENT(N2L)) THEN ALLOCATE(MYMAP(MYID)%LOC_2_GRID(0:NSIZE)) MYMAP(MYID)%LOC_2_GRID = 0 MYMAP(MYID)%LOC_2_GRID(1:NSIZE) = N2L(1:NSIZE) ELSE ALLOCATE(MYMAP(MYID)%LOC_2_GRID(0:NSIZE)) MYMAP(MYID)%LOC_2_GRID = 0 DO J= 1,NSIZE MYMAP(MYID)%LOC_2_GRID(J)=J END DO END IF END IF if(DBG_SET(dbg_sbr)) & & write(IPT,*) "END MAKE_MAP" END FUNCTION MAKE_MAP !===================================================================================| !-----------------------------------------------------------------------------------! !===================================================================================| FUNCTION FIND_MAP(HEAD,Gsize,Lsize,FOUND) RESULT(MP) IMPLICIT NONE TYPE(MAPLINK),target :: HEAD TYPE(MAP), POINTER :: MP(:) LOGICAL :: FOUND integer, intent(IN) :: Gsize integer,POINTER, intent(IN) :: Lsize(:) TYPE(MAPLINK), POINTER :: current, previous INTEGER CNT previous => HEAD current => previous%next CNT = 0 FOUND = .FALSE. nullify(mp) DO IF(.NOT. ASSOCIATED(CURRENT)) RETURN IF(.NOT. ASSOCIATED(CURRENT%MAP))& CALL FATAL_ERROR("FIND_MAP: MAP LIST LINK HAS UNASSOCIATED MAP!") IF(DBG_SET(DBG_MPI))THEN WRITE(IPT,*) "=========================================================" WRITE(IPT,*) "SEARCHING MAPS: MAP GLOBAL_SIZEs= ",CURRENT%MAP%GSIZE WRITE(IPT,*) "SEARCHING MAPS for Gsize= ",Gsize WRITE(IPT,*) "SEARCHING MAPS: MAP LOCAL_SIZEs= ",CURRENT%MAP%LSIZE WRITE(IPT,*) "SEARCHING MAPS for Lsize= ",Lsize END IF if(ALL(CURRENT%MAP%GSIZE == GSIZE) .and. SUM(abs(Lsize-CURRENT%MAP%LSIZE)) == 0 ) then MP => CURRENT%MAP FOUND = .TRUE. RETURN end if CURRENT => CURRENT%NEXT IF (CNT > 100)CALL FATAL_ERROR& &("FIND_MAP: LOOP COUNT EXCEEDED 100; STOP!") END DO END FUNCTION FIND_MAP SUBROUTINE PRINT_MAP(MP,MSG) IMPLICIT NONE TYPE(MAP),POINTER :: MP(:) CHARACTER(LEN=*),OPTIONAL :: MSG INTEGER :: I, NN,LL IF(DBG_SET(DBG_LOG)) THEN IF(PRESENT(MSG)) THEN WRITE(IPT,*) "! ==== PRINT_MAP: "//TRIM(MSG)//" ====" ELSE WRITE(IPT,*) "! ==== PRINT_MAP ====" END IF IF(.not.associated(MP)) THEN WRITE(IPT,*) "! ==== MAP NOT ASSOCIATED! ====" RETURN END IF DO I =1,size(MP) WRITE(IPT,*) "! *** proc map#",I WRITE(IPT,*) "! SIZES: G,N,L",MP(I)%GSIZE,MP(I)%NSIZE,MP(I)%LSIZE NN = -1 LL = -1 IF(ASSOCIATED(MP(I)%LOC_2_GL)) NN = ubound(MP(I)%LOC_2_GL,1) IF(ASSOCIATED(MP(I)%LOC_2_GRID)) LL = ubound(MP(I)%LOC_2_GRID,1) WRITE(IPT,*) "! LOC_2_GL Ubound=",NN WRITE(IPT,*) "! LOC_2_GRID Ubound=",LL END DO WRITE(IPT,*) "! ==== END PRINT_MAP ====" END IF END SUBROUTINE PRINT_MAP # else INTERFACE PPRINT MODULE PROCEDURE PPRINT_ARR MODULE PROCEDURE PPRINT_VEC END INTERFACE INTERFACE APRINT MODULE PROCEDURE APRINT_ARR MODULE PROCEDURE APRINT_VEC END INTERFACE !===================================================================================| CONTAINS !!INCLUDED SUBROUTINES FOLLOW !===================================================================================| # endif !==============================================================================| ! WRITE OUT VARIABLE INFORMATION TO LOCAL FILES | ! | ! USAGE EXAMPLES | ! | ! write u velocity at surface in triangle 256 to file fort.306 with iteration | ! I1 = LBOUND(U,1) ; I2 = UBOUND(U,1) | ! CALL PPRINT(306,I1,I2,KB,U,"element",256,1,1,FLOAT(IINT)) | ! | ! I1 = LBOUND(EL,1) ; I2 = UBOUND(EL,1) | ! write surface elevation at node 233 to file fort.409 with time in hours | ! CALL PPRINT(406,I1,I2,1,EL,"node",233,1,1,THOUR) | ! | ! I1 = LBOUND(T1,1) ; I2 = UBOUND(T1,1) | ! write vertical distribution of salinity at node 422 to file fort.433 | ! CALL PPRINT(433,I1,I2,KB,T1,"node",422,1,KBM1,THOUR) | ! | ! ARGUMENT LIST | ! PPRINT(IUNIT,LB1,UB1,UB2,VARP,VART,ILOC,K1,K2,REF) | ! 1.) IUNIT - UNIT NUMBER FOR OUTPUT FILE (MUST BE >= 300 .and. <7000) | ! 2.) LB1 - LOWER BOUND OF 1ST ARGUMENT OF ARRAY TO PRINT (USUAlLY 0) | ! 3.) LB2 - UPPER BOUND OF 1ST ARRAY DIMENSION (USUALLY NT OR MT) | ! NOTE: LB1/LB2 CAN BE DETERMINE AUTOMATICALLY WITH LBOUND/UBOUND | ! 4.) UB2 - UPPER BOUND OF SECOND ARRAY DIMENSION | ! UB2 = 1 FOR SURFACE ARRAYS LIKE EL,UA | ! UB2 = KB FOR 3D ARRAYS LIKE U/V | ! 5.) VARP = VARIABLE TO PRINT (ARRAY NAME = U,V,WW,EL,T1,RHO1, etc) | ! 6.) VART = VARIABLE LOCATION ("element" or "node") | ! 7.) ILOC = INDEX OF ELEMENT/NODE TO PRINT | ! 8.) K1 = LOWER RANGE OF SIGMA LEVEL TO PRINT | ! 9.) K2 = UPPER RANGE OF SIGMA LEVEL TO PRINT | ! K1 = 1,K2 = 1 FOR SURFACE VALUES ONLY | ! K1 = 1,K2 = KBM1 FOR ALL LEVELS | ! 10.) REF = REFERENCE VALUE FOR DATA (MUST BE FLOAT) | ! REF = THOURS FOR CALCULATION TIME IN HOURS | ! REF = FLOAT(IINT) FOR ITERATION NUMBER | ! 11.) IPT = UNIT TO WRITE ERRORS TO (USE IPT) | !==============================================================================| !==============================================================================| SUBROUTINE APRINT_VEC(IUNIT,VARP,VART,NOW,ILOC,MSG) USE MOD_TIME IMPLICIT NONE TYPE(TIME), INTENT(IN) :: NOW INTEGER, INTENT(IN) :: IUNIT,ILOC REAL(SP), ALLOCATABLE, INTENT(IN),TARGET :: VARP(:) CHARACTER(LEN=*), INTENT(IN) :: VART CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG REAL(SP), POINTER:: VARP_O(:) VARP_O => VARP IF(PRESENT(MSG))THEN CALL PPRINT_VEC(IUNIT,VARP_O,VART,NOW,ILOC,MSG) ELSE CALL PPRINT_VEC(IUNIT,VARP_O,VART,NOW,ILOC) END IF END SUBROUTINE APRINT_VEC !==============================================================================| SUBROUTINE PPRINT_VEC(IUNIT,VARP,VART,NOW,ILOC,MSG) USE CONTROL USE LIMS IMPLICIT NONE TYPE(TIME), INTENT(IN) :: NOW INTEGER, INTENT(IN) :: IUNIT,ILOC REAL(SP), POINTER, INTENT(IN) :: VARP(:) CHARACTER(LEN=*), INTENT(IN) :: VART CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG CHARACTER(LEN=80),parameter :: VAR_E = "element" CHARACTER(LEN=80),parameter :: VAR_N = "node" CHARACTER(LEN=100) :: STRNG CHARACTER(LEN=20) :: short INTEGER :: I,J,K,PROCMAX,II,IBND,Kopt,IERR LOGICAL :: PRINT_PROC !==============================================================================| !------------------------------------------------------------------------------| ! Process Iunit for Errors | !------------------------------------------------------------------------------| IF(IUNIT /= IPT .and. (IUNIT < 300 .or. IUNIT > 7000) )THEN CALL FATAL_ERROR('ERROR IN PPRINT',& & 'FILE UNIT < 300 AND UNIT > 7000 ARE RESERVED FOR FVCOM I/O',& & 'PLEASE INCREASE IUNIT TO 300+') END IF !------------------------------------------------------------------------------| ! Process Vartype for Errors | !------------------------------------------------------------------------------| IF(VART /= VAR_E .AND. VART /= VAR_N)THEN CALL FATAL_ERROR('VART IN PPRINT NOT CORRECT :'//TRIM(VART),& & 'SHOULD BE "'//trim(var_e)//'" or "'//trim(var_n)//'"') END IF !------------------------------------------------------------------------------| ! Process string output | !------------------------------------------------------------------------------| IF(PRESENT(MSG)) STRNG=TRIM(MSG)//"; IINT" IF(abs(IINT) .lt. 1000) THEN WRITE(SHORT,'(I5)') IINT ELSE IF(abs(IINT) .lt. 1000000) THEN WRITE(SHORT,'(I8)') IINT ELSE WRITE(SHORT,*) IINT END IF IF(USE_REAL_WORLD_TIME) THEN STRNG = TRIM(STRNG)//TRIM(SHORT)//", Date/Time:"& &//TRIM(WRITE_DATETIME(NOW,3,TIMEZONE))//"; ILOC= " ELSE STRNG = TRIM(STRNG)//TRIM(SHORT)//", Time(s):" WRITE(SHORT,'(f16.8)') SECONDS(NOW) STRNG = TRIM(STRNG)//TRIM(SHORT)//"; ILOC=" END IF WRITE(SHORT,'(I8)') ILOC STRNG = TRIM(STRNG)//TRIM(SHORT)//"; VALUE=" !------------------------------------------------------------------------------| ! Single Processor Case | !------------------------------------------------------------------------------| IF(NPROCS == 1)THEN WRITE(IUNIT,*) TRIM(STRNG),VARP(ILOC) END IF !------------------------------------------------------------------------------| ! Multi Processor Case with Element Based Variable (u,v,ww, etc) | ! Transform to Local Element ID with "ELID" | !------------------------------------------------------------------------------| IF(NPROCS /= 1 .AND. VART == var_e .AND. ELID(ILOC) /= 0)THEN WRITE(IUNIT,*) TRIM(STRNG),VARP(ELID(ILOC)) END IF !------------------------------------------------------------------------------| ! Multi Processor Case with Node Based Variable (s1,t1,rho1,e1, etc) | ! Transform to Local Node ID with "NLID" | ! If Node is Interprocessor Boundary Node, Choose Processor with Highest | ! ID Number to Write Values to File | !------------------------------------------------------------------------------| IF(NPROCS /= 1 .AND. VART == var_n .AND. NLID(ILOC) > 0)THEN PRINT_PROC = .TRUE. IF(NDE_ID(NLID(ILOC)) == 1)THEN !!BOUNDARY NODE DO II=1,NBN IF(BN_LST(II) == ILOC) IBND = II END DO PROCMAX = 10000 DO J=1,NPROCS IF(BN_NEY(IBND,J)==1) THEN IF(J < PROCMAX) PROCMAX = J END IF END DO IF(PROCMAX /= MYID) PRINT_PROC = .FALSE. !!NOT RESPONSIBLE FOR OUTPUT END IF IF(PRINT_PROC)THEN WRITE(IUNIT,*) TRIM(STRNG),VARP(NLID(ILOC)) END IF END IF # if defined (MULTIPROCESSOR) IF(.NOT. IOPROC) CALL MPI_BARRIER(MPI_FVCOM_GROUP,IERR) # endif RETURN END SUBROUTINE PPRINT_VEC !==============================================================================| !==============================================================================| SUBROUTINE APRINT_ARR(IUNIT,VARP,VART,NOW,ILOC,K1,K2,MSG) USE MOD_TIME IMPLICIT NONE TYPE(TIME), INTENT(IN) :: NOW INTEGER, INTENT(IN) :: IUNIT,ILOC,K1 INTEGER, INTENT(IN),OPTIONAL :: K2 REAL(SP), ALLOCATABLE, INTENT(IN),TARGET :: VARP(:,:) CHARACTER(LEN=*), INTENT(IN) :: VART CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG REAL(SP), POINTER:: VARP_O(:,:) VARP_O => VARP IF (PRESENT(K2)) THEN IF(PRESENT(MSG))THEN CALL PPRINT_ARR(IUNIT,VARP_O,VART,NOW,ILOC,K1,K2,MSG) ELSE CALL PPRINT_ARR(IUNIT,VARP_O,VART,NOW,ILOC,K1,K2) END IF ELSE IF(PRESENT(MSG))THEN CALL PPRINT_ARR(IUNIT,VARP_O,VART,NOW,ILOC,K1,K1,MSG) ELSE CALL PPRINT_ARR(IUNIT,VARP_O,VART,NOW,ILOC,K1) END IF END IF END SUBROUTINE APRINT_ARR !==============================================================================| SUBROUTINE PPRINT_ARR(IUNIT,VARP,VART,NOW,ILOC,K1,K2,MSG) USE CONTROL USE LIMS IMPLICIT NONE TYPE(TIME), INTENT(IN) :: NOW INTEGER, INTENT(IN) :: IUNIT,ILOC,K1 INTEGER, INTENT(IN),OPTIONAL :: K2 REAL(SP), POINTER, INTENT(IN) :: VARP(:,:) CHARACTER(LEN=*), INTENT(IN) :: VART CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG CHARACTER(LEN=80),parameter :: VAR_E = "element" CHARACTER(LEN=80),parameter :: VAR_N = "node" CHARACTER(LEN=100) :: STRNG CHARACTER(LEN=20) :: short INTEGER :: I,J,K,PROCMAX,II,IBND,Kopt,IERR LOGICAL :: PRINT_PROC !==============================================================================| !------------------------------------------------------------------------------| ! Process Iunit for Errors | !------------------------------------------------------------------------------| IF(IUNIT /= IPT .and. (IUNIT < 300 .or. IUNIT > 7000) )THEN CALL FATAL_ERROR('ERROR IN PPRINT',& & 'FILE UNIT < 300 AND UNIT > 7000 ARE RESERVED FOR FVCOM I/O',& & 'PLEASE INCREASE IUNIT TO 300+') END IF !------------------------------------------------------------------------------| ! Process Vartype for Errors | !------------------------------------------------------------------------------| IF(VART /= VAR_E .AND. VART /= VAR_N)THEN CALL FATAL_ERROR('VART IN PPRINT NOT CORRECT :'//TRIM(VART),& & 'SHOULD BE "'//trim(var_e)//'" or "'//trim(var_n)//'"') END IF !------------------------------------------------------------------------------| ! Process optional sigma level range | !------------------------------------------------------------------------------| IF(PRESENT(K2)) THEN KOPT=K2 ELSE KOPT=K1 END IF !------------------------------------------------------------------------------| ! Process string output | !------------------------------------------------------------------------------| IF(PRESENT(MSG)) STRNG=TRIM(MSG)//"; IINT" IF(abs(IINT) .lt. 1000) THEN WRITE(SHORT,'(I5)') IINT ELSE IF(abs(IINT) .lt. 1000000) THEN WRITE(SHORT,'(I8)') IINT ELSE WRITE(SHORT,*) IINT END IF IF(USE_REAL_WORLD_TIME) THEN STRNG = TRIM(STRNG)//TRIM(SHORT)//", Date/Time:"& &//TRIM(WRITE_DATETIME(NOW,3,TIMEZONE))//"; ILOC " ELSE STRNG = TRIM(STRNG)//TRIM(SHORT)//", Time(s):" WRITE(SHORT,'(f16.8)') SECONDS(NOW) STRNG = TRIM(STRNG)//TRIM(SHORT)//"; ILOC=" END IF WRITE(SHORT,'(I8)') ILOC STRNG = TRIM(STRNG)//TRIM(SHORT)//"; VALUES=" !------------------------------------------------------------------------------| ! Single Processor Case | !------------------------------------------------------------------------------| IF(NPROCS == 1)THEN WRITE(IUNIT,*) TRIM(STRNG) WRITE(IUNIT,*) (VARP(ILOC,K),K=K1,KOPT) END IF !------------------------------------------------------------------------------| ! Multi Processor Case with Element Based Variable (u,v,ww, etc) | ! Transform to Local Element ID with "ELID" | !------------------------------------------------------------------------------| IF(NPROCS /= 1 .AND. VART == var_e .AND. ELID(ILOC) /= 0)THEN WRITE(IUNIT,*) TRIM(STRNG) WRITE(IUNIT,*) (VARP(ELID(ILOC),K),K=K1,KOPT) END IF !------------------------------------------------------------------------------| ! Multi Processor Case with Node Based Variable (s1,t1,rho1,e1, etc) | ! Transform to Local Node ID with "NLID" | ! If Node is Interprocessor Boundary Node, Choose Processor with Highest | ! ID Number to Write Values to File | !------------------------------------------------------------------------------| IF(NPROCS /= 1 .AND. VART == var_n .AND. NLID(ILOC) > 0)THEN PRINT_PROC = .TRUE. IF(NDE_ID(NLID(ILOC)) == 1)THEN !!BOUNDARY NODE DO II=1,NBN IF(BN_LST(II) == ILOC) IBND = II END DO PROCMAX = 10000 DO J=1,NPROCS IF(BN_NEY(IBND,J)==1) THEN IF(J < PROCMAX) PROCMAX = J END IF END DO IF(PROCMAX /= MYID) PRINT_PROC = .FALSE. !!NOT RESPONSIBLE FOR OUTPUT END IF IF(PRINT_PROC)THEN WRITE(IUNIT,*) TRIM(STRNG) WRITE(IUNIT,*) (VARP(NLID(ILOC),K),K=K1,KOPT) END IF END IF # if defined (MULTIPROCESSOR) IF(.NOT. IOPROC) CALL MPI_BARRIER(MPI_FVCOM_GROUP,IERR) # endif RETURN END SUBROUTINE PPRINT_ARR !==============================================================================| END MODULE MOD_PAR # endif