Newer
Older
Dave Whipp
committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
! |
! ||===\\ |
! || \\ |
! || || //==\\ || || //==|| ||/==\\ |
! || || || || || || || || || || |
! || // || || || || || || || |
! ||===// \\==// \\==\\ \\==\\ || |
! |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
! |
! ADJUST MATERIALN MARCH 2013 |
! |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
subroutine adjust_materialn (params)
use definitions
!------------------------------------------------------------------------------|
!(((((((((((((((( 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
!------------------------------------------------------------------------------|
!(((((((((((((((( declaration of the subroutine internal variables )))))))))))))
!------------------------------------------------------------------------------|
integer,dimension(:),allocatable :: matntemp
integer :: iproc,nproc,ierr,err,i,matncount,matnorig
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
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
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------