Newer
Older
Dave Whipp
committed
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
! |
! ||===\\ |
! || \\ |
! || || //==\\ || || //==|| ||/==\\ |
! || || || || || || || || || || |
! || // || || || || || || || |
! ||===// \\==// \\==\\ \\==\\ || |
! |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
! |
! ADJUST MATERIALN MARCH 2013 |
! |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
Dave Whipp
committed
use definitions
Dave Whipp
committed
!------------------------------------------------------------------------------|
!(((((((((((((((( Purpose of the routine ))))))))))))))))))))))))))))))))))))))
!------------------------------------------------------------------------------|
! This routine adjusts the params%materialn array to reflect the reduced number
! of surfaces/LSFs
!------------------------------------------------------------------------------|
!(((((((((((((((( declaration of the subroutine arguments ))))))))))))))))))))
!------------------------------------------------------------------------------|
implicit none
include 'mpif.h'
type (parameters) params
Dave Whipp
committed
!------------------------------------------------------------------------------|
!(((((((((((((((( declaration of the subroutine internal variables )))))))))))))
!------------------------------------------------------------------------------|
integer,dimension(:),allocatable :: matntemp
integer :: iproc,nproc,ierr,i,matncount,matnorig
Dave Whipp
committed
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
call mpi_comm_size (mpi_comm_world,nproc,ierr)
call mpi_comm_rank (mpi_comm_world,iproc,ierr)
! We know that the number of surfaces/LSFs has changed, so we create a new
! params%materialn array for the reduced number of surfaces/LSFs
! First we store the original number of surface-associated materials
matnorig=params%nsorig
! Now we allocate a temporary array to store the old materialn, fill it and
! deallocate params%materialn
allocate(matntemp(0:matnorig),stat=threadinfo%err)
if (params%debug.gt.1) call heap (threadinfo,'matntemp','adjust_materialn',size(matntemp),'dp',+1)
matntemp=params%materialn
if (params%debug.gt.1) call heap (threadinfo,'params%materialn','adjust_materialn',size(params%materialn),'dp',-1)
deallocate (params%materialn)
! Now we reallocate the smaller params%materialn, fill it and deallocate matntemp
allocate (params%materialn(0:params%ns),stat=threadinfo%err)
if (params%debug.gt.1) call heap (threadinfo,'params%materialn', 'adjust_materialn',size(params%materialn),'dp',+1)
matncount=0
params%materialn(0)=matntemp(0)
do i=1,matnorig
if (params%surfremindex(i) > 0) then
matncount=matncount+1
params%materialn(matncount)=matntemp(i)
endif
enddo
if (params%debug.gt.1) call heap (threadinfo,'matntemp','adjust_materialn',size(matntemp),'dp',-1)
deallocate (matntemp)
end subroutine adjust_materialn
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------