mpdalc.f90

Go to the documentation of this file.

 
 
MODULE mpdalc
    USE mpdef
    IMPLICIT NONE
    SAVE
    ! variables
    INTEGER(mpl) :: numwordsalloc = 0
    INTEGER(mpl) :: maxwordsalloc = 0
    INTEGER(mpi) :: nummpalloc = 0
    INTEGER(mpi) :: nummpdealloc = 0
    INTEGER(mpi) :: printflagalloc = 0
 
    INTERFACE mpalloc
        MODULE PROCEDURE mpallocdvec, mpallocfvec, mpallocivec, &
            mpallocfarr, mpallociarr, mpalloclarr, mpalloclist, mpalloccvec
    END INTERFACE mpalloc
    INTERFACE mpdealloc
        MODULE PROCEDURE mpdeallocdvec, mpdeallocfvec, mpdeallocivec, &
            mpdeallocfarr, mpdeallociarr, mpdealloclarr, mpdealloclist, mpdealloccvec
    END INTERFACE mpdealloc
 
CONTAINS
    ! allocate dynamic vector or array
    SUBROUTINE mpallocdvec(array,length,text)
        REAL(mpd), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: length
        CHARACTER (LEN=*), INTENT(IN) :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(length),stat=ifail)
        CALL mpalloccheck(ifail,(mpd*length)/mpi,text)
    END SUBROUTINE mpallocdvec
 
    SUBROUTINE mpallocfvec(array,length,text)
        REAL(mps), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: length
        CHARACTER (LEN=*), INTENT(IN) :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(length),stat=ifail)
        CALL mpalloccheck(ifail,(mps*length)/mpi,text)
    END SUBROUTINE mpallocfvec
 
    SUBROUTINE mpallocivec(array,length,text)
        INTEGER(mpi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: length
        CHARACTER (LEN=*), INTENT(IN) :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(length),stat=ifail)
        CALL mpalloccheck(ifail,length,text)
    END SUBROUTINE mpallocivec
 
    SUBROUTINE mpallocfarr(array,rows,cols,text)
        REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: rows
        INTEGER(mpl), INTENT(IN) :: cols
        CHARACTER (LEN=*), INTENT(IN)  :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(rows,cols),stat=ifail)
        CALL mpalloccheck(ifail,(mps*rows*cols)/mpi,text)
    END SUBROUTINE mpallocfarr
 
    SUBROUTINE mpallociarr(array,rows,cols,text)
        INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: rows
        INTEGER(mpl), INTENT(IN) :: cols
        CHARACTER (LEN=*), INTENT(IN)  :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(rows,cols),stat=ifail)
        CALL mpalloccheck(ifail,rows*cols,text)
    END SUBROUTINE mpallociarr
 
    SUBROUTINE mpalloclarr(array,rows,cols,text)
        INTEGER(mpl), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: rows
        INTEGER(mpl), INTENT(IN) :: cols
        CHARACTER (LEN=*), INTENT(IN)  :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(rows,cols),stat=ifail)
        CALL mpalloccheck(ifail,(mpl*rows*cols)/mpi,text)
    END SUBROUTINE mpalloclarr
 
    SUBROUTINE mpalloclist(array,length,text)
        TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: length
        CHARACTER (LEN=*), INTENT(IN) :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(length),stat=ifail)
        CALL mpalloccheck(ifail,((mps+mpi)*length)/mpi,text)
    END SUBROUTINE mpalloclist
 
    SUBROUTINE mpalloccvec(array,length,text)
        CHARACTER, DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
        INTEGER(mpl), INTENT(IN) :: length
        CHARACTER (LEN=*), INTENT(IN) :: text
 
        INTEGER(mpi) :: ifail
        ALLOCATE (array(length),stat=ifail)
        CALL mpalloccheck(ifail,(length+mpi-1)/mpi,text)
    END SUBROUTINE mpalloccvec
 
    SUBROUTINE mpalloccheck(ifail,numwords,text)
        INTEGER(mpi), INTENT(IN) :: ifail
        INTEGER(mpl), INTENT(IN) :: numwords
        CHARACTER (LEN=*), INTENT(IN)  :: text
        IF (ifail == 0) THEN
            nummpalloc=nummpalloc+1
            numwordsalloc = numwordsalloc + numwords
            maxwordsalloc = max(maxwordsalloc, numwordsalloc)
            IF (printflagalloc /= 0) THEN
                print *, ' MPALLOC allocated ', numwords, ' words for : ', text
                print *, ' words used ', numwordsalloc, maxwordsalloc
            ENDIF
        ELSE
            print *, ' MPALLOC failed to allocate ', numwords, ' words for : ', text
            print *, ' MPALLOC words used ', numwordsalloc, maxwordsalloc
            print *, ' MPALLOC stat = ', ifail
            CALL peend(30,'Aborted, memory allocation failed')
            stop
        ENDIF
    END SUBROUTINE mpalloccheck
    ! deallocate dynamic vector or array
    SUBROUTINE mpdeallocdvec(array)
        REAL(mpd), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = (mpd*size(array,kind=mpl))/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdeallocdvec
 
    SUBROUTINE mpdeallocfvec(array)
        REAL(mps), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = (mps*size(array,kind=mpl))/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdeallocfvec
 
    SUBROUTINE mpdeallocivec(array)
        INTEGER(mpi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = size(array,kind=mpl)
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdeallocivec
 
    SUBROUTINE mpdeallocfarr(array)
        REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = (mps*size(array,kind=mpl))/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdeallocfarr
 
    SUBROUTINE mpdeallociarr(array)
        INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = size(array,kind=mpl)
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdeallociarr
 
    SUBROUTINE mpdealloclarr(array)
        INTEGER(mpl), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = (mpl*size(array,kind=mpl))/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdealloclarr
 
    SUBROUTINE mpdealloclist(array)
        TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = ((mpi+mps)*size(array,kind=mpl))/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdealloclist
 
    SUBROUTINE mpdealloccvec(array)
        CHARACTER, DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
 
        INTEGER(mpi) :: ifail
        INTEGER(mpl) :: isize
        isize = (size(array,kind=mpl)+mpi-1)/mpi
        DEALLOCATE (array,stat=ifail)
        CALL mpdealloccheck(ifail,isize)
    END SUBROUTINE mpdealloccvec
 
    SUBROUTINE mpdealloccheck(ifail,numwords)
        INTEGER(mpi), INTENT(IN) :: ifail
        INTEGER(mpl), INTENT(IN) :: numwords
        IF (ifail == 0) THEN
            numwordsalloc = numwordsalloc - numwords
            nummpdealloc=nummpdealloc+1
            IF (printflagalloc /= 0) THEN
                print *, ' MPDEALLOC deallocated ', numwords, ' words '
                print *, ' words used ', numwordsalloc, maxwordsalloc
            ENDIF
        ELSE
            print *, ' MPDEALLOC failed to deallocate ', numwords, ' words'
            print *, ' MPDEALLOC words used ', numwordsalloc, maxwordsalloc
            print *, ' MPDEALLOC stat = ', ifail
            CALL peend(31,'Aborted, memory deallocation failed')
            stop
        ENDIF
    END SUBROUTINE mpdealloccheck
 
END MODULE mpdalc