OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_inimap2d_file_spmd.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "param_c.inc"
#include "scr03_c.inc"
#include "scr17_c.inc"
#include "task_c.inc"
#include "units_c.inc"
#include "chara_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_inimap2d_file_spmd (x, v, itab, ipart_state, nodtag, ipart, iparts, ipartq, iparttg, mat_param, igeo, iparg, ixs, ixq, ixtg, elbuf_tab, multi_fvm, bufmat, ipm)

Function/Subroutine Documentation

◆ stat_inimap2d_file_spmd()

subroutine stat_inimap2d_file_spmd ( dimension(3,numnod), intent(in) x,
dimension(3,numnod), intent(in) v,
integer, dimension(numnod), intent(in) itab,
integer, dimension(npart), intent(in) ipart_state,
integer, dimension(numnod), intent(inout) nodtag,
integer, dimension(lipart1,*), intent(in) ipart,
integer, dimension(*), target iparts,
integer, dimension(*), target ipartq,
integer, dimension(*), target iparttg,
type(matparam_struct_), dimension(nummat), intent(in) mat_param,
integer, dimension(npropgi,numgeo), intent(in) igeo,
integer, dimension(nparg,*), intent(in) iparg,
integer, dimension(nixs,numels), intent(in) ixs,
integer, dimension(nixq,numelq), intent(in) ixq,
integer, dimension(nixtg,numeltg), intent(in) ixtg,
type (elbuf_struct_), dimension(ngroup), intent(in), target elbuf_tab,
type(multi_fvm_struct), intent(in) multi_fvm,
dimension(*), target bufmat,
integer, dimension(npropmi,*), intent(inout) ipm )

Definition at line 48 of file stat_inimap2d_file_spmd.F.

53C-----------------------------------------------
54C Description
55C-----------------------------------------------
56C This subroutine is generating mapping data to be used with /INIMAP2D option.
57C include file is incremented starting from ROOT_INIMAP_0001.inimap
58C It contains 2D fonctions for submaterial data (volume fraction, mass density, energy density)
59C and also function for global velocity
60C User can use the generated file in a second run using #include command in the new Starter input file (target mesh)
61C-----------------------------------------------
62C M o d u l e s
63C-----------------------------------------------
64 USE elbufdef_mod
65 USE state_inimap_mod
66 USE multi_fvm_mod
67 USE message_mod
68 USE inoutfile_mod
69 USE multimat_param_mod , ONLY : m51_n0phas, m51_nvphas
70 USE matparam_def_mod, ONLY : matparam_struct_
71 use element_mod , only : nixs,nixq,nixtg
72C-----------------------------------------------
73C I m p l i c i t T y p e s
74C-----------------------------------------------
75#include "implicit_f.inc"
76C-----------------------------------------------
77C C o m m o n B l o c k s
78C-----------------------------------------------
79#include "com01_c.inc"
80#include "com04_c.inc"
81#include "com08_c.inc"
82#include "param_c.inc"
83#include "scr03_c.inc"
84#include "scr17_c.inc"
85#include "task_c.inc"
86#include "units_c.inc"
87#include "chara_c.inc"
88C-----------------------------------------------
89C D u m m y A r g u m e n t s
90C-----------------------------------------------
91 INTEGER,INTENT(IN) :: ITAB(NUMNOD), IPART(LIPART1,*),IGEO(NPROPGI,NUMGEO), IXS(NIXS,NUMELS), IPART_STATE(NPART),
92 . IPARG(NPARG,*),IXQ(NIXQ,NUMELQ),IXTG(NIXTG,NUMELTG)
93 INTEGER, INTENT(INOUT) :: NODTAG(NUMNOD),
94 . IPM(NPROPMI,*)
95 INTEGER, TARGET :: IPARTS(*),IPARTQ(*),IPARTTG(*)
96 my_real,INTENT(IN) :: x(3,numnod),v(3,numnod)
97 my_real, INTENT(IN), TARGET :: bufmat(*)
98 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET, INTENT(IN) :: ELBUF_TAB
99 TYPE(MULTI_FVM_STRUCT), INTENT(IN) :: MULTI_FVM
100 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
101C-----------------------------------------------
102C L o c a l V a r i a b l e s
103C-----------------------------------------------
104 INTEGER I, N, JJ, J, IPRT, K, KK, INOD
105 INTEGER NG, NEL, NFT, LFT, LLT, ITY, ISOLNOD, NPT
106 INTEGER NUM_CENTROIDS, MLW, NBMAT, NB2, ISUBMAT, NNOD
107 INTEGER NUVAR
108 TYPE(G_BUFEL_) ,POINTER :: GBUF
109 my_real min_x,min_y,min_z,max_x,max_y,max_z,p0(3),p0_inf(3),p0_sup(3),length
110 my_real shift_cy,shift_cz
111 my_real shift_ny,shift_nz
112 my_real lx,ly,lz
113 my_real dx,dy,dz
114 my_real dotprod,tol,xyz(3),vel(3),dist,vect(3)
115 CHARACTER FILNAM*2048, SHORTNAME*128, CHSTAT*4
116 INTEGER XMIN_CELL_ID,YMIN_CELL_ID,ZMIN_CELL_ID,XMAX_CELL_ID,YMAX_CELL_ID,ZMAX_CELL_ID
117 INTEGER IS_ITY_1, IS_ITY_2, IS_ITY_7, IMAT, NPAR, IADBUF
118 INTEGER, POINTER,DIMENSION(:) :: IPART_PTR
119 my_real, POINTER,DIMENSION(:) :: uparam
120 TYPE(BUF_MAT_) ,POINTER :: MBUF
121 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: GET_CELL_FOM_CENTROID !(NG,I+NFT)
122 INTEGER NPTS(NSPMD),NCELL(NSPMD),NPTS_TOT,NCELL_TOT
123 my_real, DIMENSION(:,:), ALLOCATABLE :: work
124 my_real :: len_(nspmd),len_tot
125 my_real :: shift_cy_min, shift_ny_min, shift_cz_min, shift_nz_min
126 INTEGER, ALLOCATABLE, DIMENSION(:) :: IDX, NODTAG_G
127 INTEGER :: CELL_ID
128 INTEGER :: LEN, LEN_TMP_NAME
129 CHARACTER :: TMP_NAME*2048
130 INTEGER :: IFILNAM(2048)
131C-----------------------------------------------
132C P r e - C o n d i t i o n
133C-----------------------------------------------
134 IF(n2d == 0)RETURN
135C-----------------------------------------------
136C S o u r c e L i n e s
137C-----------------------------------------------
138
139 !---INITIALIZATION
140 !
141 state_inimap_call_number = state_inimap_call_number +1 !number of written files ROOT_INIMAP_00**.rad
142 num_centroids = 0
143 mlw=0
144 !box containing user domain :
145 min_x = ep20
146 min_y = ep20
147 min_z = ep20
148 max_x = -ep20
149 max_y = -ep20
150 max_z = -ep20
151 !detecting elem types to manager error messages :
152 is_ity_1 = 0
153 is_ity_2 = 0
154 is_ity_7 = 0
155
156 !---ALLOCATIONS
157 !
158 IF(.NOT.(ALLOCATED(state_inimap_buf))) THEN
159 IF(ispmd/=0)THEN
160 ALLOCATE(state_inimap_buf(1))
161 ELSE
162 ALLOCATE(state_inimap_buf(nspmd)) !process 0 will gather all data
163 ENDIF
164 ENDIF
165
166 !---ENUMARATION : ELEM TYPES AND BOX DIMENSION
167 !
168 DO ng=1,ngroup
169 ity =iparg(5,ng)
170 isolnod = iparg(28,ng)
171 nel =iparg(2,ng)
172 nft =iparg(3,ng)
173 gbuf => elbuf_tab(ng)%GBUF
174 mlw = iparg(1,ng)
175 lft=1
176 llt=nel
177 npt=0
178 IF(ity == 1) THEN
179 !---bricks
180 is_ity_1=1
181 npt=isolnod
182 ipart_ptr => iparts(1:numels)
183 ELSEIF(ity == 2)THEN
184 !---quads
185 is_ity_2=1
186 npt=4
187 ipart_ptr => ipartq(1:numelq)
188 ELSEIF(ity == 7 .AND. n2d /= 0)THEN
189 !---Triangles
190 is_ity_7=1
191 npt=3
192 ipart_ptr => iparttg(1:numeltg)
193 ENDIF
194 IF(npt /= 0)THEN
195 DO i=lft,llt
196 n = i + nft
197 iprt=ipart_ptr(n)
198 imat =ipart(1,iprt)
199 IF(ipart_state(iprt)==0)cycle
200 num_centroids = num_centroids +1
201 DO k=1,npt
202 IF(is_ity_1==1)inod=ixs(1+k,n)
203 IF(is_ity_2==1)inod=ixq(1+k,n) !pass IX (pointer, argument) and nix => generic routine
204 IF(is_ity_7==1)inod=ixtg(1+k,n) !pass IX (pointer, argument) and nix => generic routine
205 IF(is_ity_1==1)nodtag(ixs(1+k,n)) = 1
206 IF(is_ity_2==1)nodtag(ixq(1+k,n)) = 1
207 IF(is_ity_7==1)nodtag(ixtg(1+k,n)) = 1
208 IF(x(1,inod)<min_x)THEN
209 min_x=x(1,inod)
210 xmin_cell_id = n
211 ENDIF
212 IF(x(2,inod)<min_y)THEN
213 min_y=x(2,inod)
214 ymin_cell_id = n
215 ENDIF
216 IF(x(3,inod)<min_z)THEN
217 min_z=x(3,inod)
218 zmin_cell_id = n
219 ENDIF
220 IF(x(1,inod)>max_x)THEN
221 max_x=x(1,inod)
222 xmax_cell_id = n
223 ENDIF
224 IF(x(2,inod)>max_y)THEN
225 max_y=x(2,inod)
226 ymax_cell_id = n
227 ENDIF
228 IF(x(3,inod)>max_z)THEN
229 max_z=x(3,inod)
230 zmax_cell_id = n
231 ENDIF
232 ENDDO
233 END DO
234 ELSE
235 !no related cells: bricks, quads, and triangles only
236 END IF
237 END do! next NG
238
239 !---NUMBERING :
240 ! +--CENTROIDS
241 state_inimap_buf(1)%NUM_CENTROIDS = num_centroids
242 state_inimap_buf(1)%NUM_POINTS = 0
243 ! +--FIRST ESTIMATION OF NODE NUMBER (DUPLICATED PROJECTIONS AT THIS STEP)
244 nnod=0
245 DO i=1,numnod
246 IF(nodtag(i) == 1)THEN
247 nnod=nnod+1
248 ENDIF
249 ENDDO
250
251 !---ANOTHER ALLOCATIONS
252 !
253 IF(.NOT.ALLOCATED(state_inimap_buf(1)%CELL_IDS))ALLOCATE(state_inimap_buf(1)%CELL_IDS(num_centroids))
254 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_CENTROIDS))ALLOCATE(state_inimap_buf(1)%POS_CENTROIDS(num_centroids))
255 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS2_CENTROIDS))ALLOCATE(state_inimap_buf(1)%POS2_CENTROIDS(num_centroids))
256 IF(.NOT.ALLOCATED(get_cell_fom_centroid))THEN
257 ALLOCATE(get_cell_fom_centroid(2,num_centroids))
258 ENDIF
259
260 IF(num_centroids > 0)THEN
261 !---BOX CONTAINING USER-2D-DOMAIN
262 !
263 lx=max_x-min_x
264 ly=max_y-min_y
265 lz=max_z-min_z
266 vect(1:3)=(/lx,ly,lz/)
267 length = sqrt(vect(2)*vect(2) + vect(3)*vect(3)) !1d axis length (needed to normalize following dot products)
268 IF(is_ity_1==1)THEN
269 p0_inf(2) = sum( x(2,ixs(2:9,ymin_cell_id)) ) / npt
270 p0_inf(3) = sum( x(3,ixs(2:9,zmin_cell_id)) ) / npt
271 ELSEIF(is_ity_2==1)THEN
272 p0_inf(2) = sum( x(2,ixq(2:5,ymin_cell_id)) ) / npt
273 p0_inf(3) = sum( x(3,ixq(2:5,zmin_cell_id)) ) / npt
274 ELSEIF(is_ity_7==1)THEN
275 p0_inf(2) = sum( x(2,ixtg(2:4,ymin_cell_id)) ) / npt
276 p0_inf(3) = sum( x(3,ixtg(2:4,zmin_cell_id)) ) / npt
277 ENDIF
278 shift_cy = p0_inf(2)
279 shift_cz = p0_inf(3)
280 state_inimap_buf(1)%SHIFT_Cy = shift_cy
281 state_inimap_buf(1)%SHIFT_Cz = shift_cz
282 state_inimap_buf(1)%LENGTH = length
283 ELSE
284 state_inimap_buf(1)%SHIFT_Cy = zero
285 state_inimap_buf(1)%SHIFT_Cz = zero
286 state_inimap_buf(1)%LENGTH = zero
287 ENDIF
288
289 !---STARTING POINT OF FIRST NODE IN GENERAL FRAME (SHIFT_N)
290 ! SHIFT_N : nodal posisiton (first node along axis)
291 ! SHIFT_C : cell centroid position (first centroid along axis)
292 ! by nature : SHIFT_N < SHIFT_C
293 !
294 shift_ny=min_y
295 shift_nz=min_z
296 state_inimap_buf(1)%SHIFT_Ny = shift_ny
297 state_inimap_buf(1)%SHIFT_Nz = shift_nz
298
299 !---ABSCISSA : CENTROIDS POSITION LIST ( STATE_INIMAP_BUF(1)%POS_CENTROIDS(1:NUM_CENTROIDS) )
300 !
301 ALLOCATE(work(num_centroids,3))
302 k=1
303 DO ng=1,ngroup
304 ity =iparg(5,ng)
305 isolnod = iparg(28,ng)
306 nel =iparg(2,ng)
307 nft =iparg(3,ng)
308 gbuf => elbuf_tab(ng)%GBUF
309 mlw = iparg(1,ng)
310 lft=1
311 llt=nel
312 IF(npt /= 0)THEN
313 DO i=lft,llt
314 n = i + nft
315 iprt=ipart_ptr(n)
316 IF(ipart_state(iprt)==0)cycle
317 !pointer here
318 IF(is_ity_1==1)THEN
319 p0(2) = sum( x(2,ixs(2:9,n)) ) / npt
320 p0(3) = sum( x(3,ixs(2:9,n)) ) / npt
321 cell_id = ixs(nixs,n)
322 ELSEIF(is_ity_2==1)THEN
323 p0(2) = sum( x(2,ixq(2:5,n)) ) / npt
324 p0(3) = sum( x(3,ixq(2:5,n)) ) / npt
325 cell_id = ixq(nixq,n)
326 ELSEIF(is_ity_7==1)THEN
327 p0(2) = sum( x(2,ixtg(2:4,n)) ) / npt
328 p0(3) = sum( x(3,ixtg(2:4,n)) ) / npt
329 cell_id = ixtg(nixtg,n)
330 ENDIF
331 !STATE_INIMAP_BUF(1)%POS_CENTROIDS(K) = P0(2)
332 !STATE_INIMAP_BUF(1)%POS2_CENTROIDS(K) = P0(3)
333 !STATE_INIMAP_BUF(1)%CELL_IDS(K) = CELL_ID
334 work(k,1) = p0(2)
335 work(k,2) = p0(3)
336 work(k,3) = cell_id !bug in sp
337 get_cell_fom_centroid(1,k) = ng
338 get_cell_fom_centroid(2,k) = i
339 k=k+1
340 END DO
341 END IF
342 END do! next NG
343
344
345 !---SORTING : UNIQUE OUTPUT NOT DEPENDING ON DOMAIN DECOMPOSITION (by cell_ids)
346 IF(.NOT.ALLOCATED(idx))ALLOCATE(idx(num_centroids))
347 DO k=1,num_centroids ; idx(k)=k; ENDDO
348 IF(num_centroids>0) CALL quicksort(work(:,3), idx, 1, num_centroids)
349
350 DO k=1,num_centroids
351 state_inimap_buf(1)%POS_CENTROIDS(k) = work(idx(k),1)
352 state_inimap_buf(1)%POS2_CENTROIDS(k) = work(idx(k),2)
353 state_inimap_buf(1)%CELL_IDS(k) = work(k,3)
354 ENDDO
355 IF(ALLOCATED(work))DEALLOCATE(work)
356
357
358 !---CELL DATA TREATMENT
359 ! storing submaterial data : vfrac,rho,E
360 !
361 IF(num_centroids > 0)THEN
362 IF(mlw==151)THEN
363 nbmat = multi_fvm%NBMAT
364 ELSEIF(mlw==51)THEN
365 nbmat = 4
366 ELSE
367 nbmat = 1
368 ENDIF
369 state_inimap_buf(1)%MLW = mlw
370 state_inimap_buf(1)%NSUBMAT = nbmat
371 ALLOCATE(state_inimap_buf(1)%SUBMAT(nbmat))
372 DO i=1,nbmat
373 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%VFRAC(num_centroids))
374 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%RHO(num_centroids))
375 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%E(num_centroids))
376 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%PRES(num_centroids))
377 ENDDO
378 IF(mlw==151)THEN
379 !velocities
380 state_inimap_buf(1)%NUM_POINTS = num_centroids
381 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_NODES))ALLOCATE(state_inimap_buf(1)%POS_NODES(num_centroids))
382 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS2_NODES))ALLOCATE(state_inimap_buf(1)%POS2_NODES(num_centroids))
383 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL_NODES))ALLOCATE(state_inimap_buf(1)%VEL_NODES(num_centroids))
384 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL2_NODES))ALLOCATE(state_inimap_buf(1)%VEL2_NODES(num_centroids))
385 IF(.NOT.ALLOCATED(state_inimap_buf(1)%NODE_IDS))ALLOCATE(state_inimap_buf(1)%NODE_IDS(num_centroids))
386
387 DO k=1, num_centroids
388 ng = get_cell_fom_centroid(1,idx(k))
389 i = get_cell_fom_centroid(2,idx(k))
390 nft = iparg(3,ng)
391 state_inimap_buf(1)%POS_NODES(k) = state_inimap_buf(1)%POS_CENTROIDS(k)
392 state_inimap_buf(1)%POS2_NODES(k) = state_inimap_buf(1)%POS2_CENTROIDS(k)
393 state_inimap_buf(1)%VEL_NODES(k) = multi_fvm%VEL(2,i+nft)
394 state_inimap_buf(1)%VEL2_NODES(k) = multi_fvm%VEL(3,i+nft)
395 state_inimap_buf(1)%NODE_IDS(k) = state_inimap_buf(1)%CELL_IDS(k)
396 ENDDO
397 !submat
398 DO isubmat=1,nbmat
399 DO k=1, num_centroids
400 ng = get_cell_fom_centroid(1,idx(k))
401 i = get_cell_fom_centroid(2,idx(k))
402 nft = iparg(3,ng)
403 state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(k) = multi_fvm%PHASE_ALPHA(isubmat,i+nft)
404 state_inimap_buf(1)%SUBMAT(isubmat)%RHO(k) = multi_fvm%PHASE_RHO(isubmat,i+nft)
405 state_inimap_buf(1)%SUBMAT(isubmat)%E(k) = multi_fvm%PHASE_EINT(isubmat,i+nft)
406 state_inimap_buf(1)%SUBMAT(isubmat)%PRES(k) = multi_fvm%PRES(i+nft)
407 ENDDO
408 ENDDO
409 ELSEIF(mlw==51)THEN
410 nb2=0
411 DO isubmat=1,nbmat
412 DO k=1, num_centroids
413 ng = get_cell_fom_centroid(1,idx(k))
414 i = get_cell_fom_centroid(2,idx(k))
415 nft = iparg(3,ng)
416 nel = iparg(2,ng)
417 n = i + nft
418 iprt=ipart_ptr(n)
419 imat =ipart(1,iprt)
420 IF(mat_param(imat)%MULTIMAT%MID(isubmat) == 0)EXIT !submaterial not defined.
421 nb2=max(nb2,ipm(5,imat))
422 iadbuf = ipm(7,imat)
423 npar = ipm(9,imat)
424 nuvar = ipm(8,imat)
425 uparam => bufmat(iadbuf:iadbuf+npar-1)
426 kk = m51_n0phas + (uparam(276+isubmat)-1)*m51_nvphas !bug in SP
427 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
428 state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(k) = mbuf%VAR(nel*(01+kk-1)+i)
429 state_inimap_buf(1)%SUBMAT(isubmat)%RHO(k) = mbuf%VAR(nel*(12+kk-1)+i)
430 state_inimap_buf(1)%SUBMAT(isubmat)%E(k) = mbuf%VAR(nel*(08+kk-1)+i)
431 state_inimap_buf(1)%SUBMAT(isubmat)%PRES(k) = mbuf%VAR(nel*(18+kk-1)+i)
432 ENDDO
433 ENDDO
434 state_inimap_buf(1)%NSUBMAT = nb2
435 ELSE !---mono-material laws
436 DO k=1, num_centroids
437 ng = get_cell_fom_centroid(1,idx(k))
438 i = get_cell_fom_centroid(2,idx(k))
439 gbuf => elbuf_tab(ng)%GBUF
440 nel =iparg(2,ng)
441 state_inimap_buf(1)%SUBMAT(1)%VFRAC(k) = 1.d00
442 state_inimap_buf(1)%SUBMAT(1)%RHO(k) = gbuf%RHO(i)
443 state_inimap_buf(1)%SUBMAT(1)%E(k) = gbuf%EINT(i)
444 state_inimap_buf(1)%SUBMAT(1)%PRES(k) = -third * (gbuf%SIG(i) + gbuf%SIG(i + nel) + gbuf%SIG(i + 2 * nel))
445 ENDDO
446 ENDIF
447 ENDIF
448
449 !---VELOCITY TREATMENT FOR STAGGERED SCHEME
450 !
451 IF(num_centroids > 0)THEN
452 IF(mlw /= 151)THEN
453 ALLOCATE(work(numnod,4))
454 !---VELOCITY : WRITE IN DOMAIN BUFFER (SORTED)
455 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_NODES))ALLOCATE(state_inimap_buf(1)%POS_NODES(nnod))
456 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS2_NODES))ALLOCATE(state_inimap_buf(1)%POS2_NODES(nnod))
457 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL_NODES))ALLOCATE(state_inimap_buf(1)%VEL_NODES(nnod))
458 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL2_NODES))ALLOCATE(state_inimap_buf(1)%VEL2_NODES(nnod))
459 IF(.NOT.ALLOCATED(state_inimap_buf(1)%NODE_IDS))ALLOCATE(state_inimap_buf(1)%NODE_IDS(nnod))
460 nnod=0
461 DO i=1,numnod
462 IF(nodtag(i) == 1)THEN
463 nnod=nnod+1
464 !STATE_INIMAP_BUF(1)%POS_NODES(NNOD) = X(2,I)
465 !STATE_INIMAP_BUF(1)%POS2_NODES(NNOD) = X(3,I)
466 !STATE_INIMAP_BUF(1)%VEL_NODES(NNOD) = V(2,I)
467 !STATE_INIMAP_BUF(1)%VEL2_NODES(NNOD) = V(3,I)
468 work(nnod,1) = x(2,i)
469 work(nnod,2) = x(3,i)
470 work(nnod,3) = v(2,i)
471 work(nnod,4) = v(3,i)
472 state_inimap_buf(1)%NODE_IDS(nnod) = itab(i)
473 ENDIF
474 ENDDO
475 state_inimap_buf(1)%NUM_POINTS=nnod
476 !---SORTING : UNIQUE OUTPUT NOT DEPENDING ON DOMAIN DECOMPOSITION
477 IF(ALLOCATED(idx))DEALLOCATE(idx)
478 IF(.NOT.ALLOCATED(idx))ALLOCATE(idx(nnod))
479 DO k=1,nnod ; idx(k)=k; ENDDO
480 CALL quicksort_i2(state_inimap_buf(1)%NODE_IDS(:), idx, 1, nnod)
481 DO k=1,nnod
482 state_inimap_buf(1)%POS_NODES(k) = work(idx(k),1)
483 state_inimap_buf(1)%POS2_NODES(k) = work(idx(k),2)
484 state_inimap_buf(1)%VEL_NODES(k) = work(idx(k),3)
485 state_inimap_buf(1)%VEL2_NODES(k) = work(idx(k),4)
486 ENDDO
487 IF(ALLOCATED(work))DEALLOCATE(work)
488
489
490 ELSE
491 !LAW 151 (colocated)
492 !already doneabove
493 ENDIF
494 ENDIF
495
496C-----------------------------------------------
497C S P M D E x c h a n g e
498C-----------------------------------------------
499 IF(nspmd > 1)THEN
500 CALL spmd_state_inimap_exch_siz()
501 CALL spmd_state_inimap2d_exch_data()
502 !
503 IF(ispmd == 0)THEN
504 shift_cy_min = state_inimap_buf(1)%SHIFT_Cy
505 shift_ny_min = state_inimap_buf(1)%SHIFT_Ny
506 shift_cz_min = state_inimap_buf(1)%SHIFT_Cz
507 shift_nz_min = state_inimap_buf(1)%SHIFT_Nz
508 DO i=2,nspmd
509 IF(state_inimap_buf(i)%NUM_CENTROIDS==0)cycle
510 shift_cy_min =min(shift_cy_min, state_inimap_buf(i)%SHIFT_Cy)
511 shift_ny_min =min(shift_ny_min, state_inimap_buf(i)%SHIFT_Ny)
512 shift_cz_min =min(shift_cz_min, state_inimap_buf(i)%SHIFT_Cz)
513 shift_nz_min =min(shift_nz_min, state_inimap_buf(i)%SHIFT_Nz)
514 ENDDO
515 state_inimap_buf(1)%SHIFT_Cy = shift_cy_min
516 state_inimap_buf(1)%SHIFT_Ny = shift_ny_min
517 state_inimap_buf(1)%SHIFT_Cz = shift_cz_min
518 state_inimap_buf(1)%SHIFT_Nz = shift_nz_min
519 ENDIF
520 ENDIF
521
522C-----------------------------------------------
523C S P M D - G a t h e r i n g & S o r t i n g
524C-----------------------------------------------
525 len_tot=state_inimap_buf(1)%LENGTH ;
526 ncell_tot = state_inimap_buf(1)%NUM_CENTROIDS ;
527 IF(ispmd == 0 .AND. nspmd > 1)THEN
528 !--cumulated dimensions
529 !
530 npts_tot = 0
531 ncell_tot = 0
532 len_tot = zero
533 DO i=1,nspmd
534 IF(state_inimap_buf(i)%NUM_CENTROIDS==0)THEN
535 npts(i)=0
536 len_(i)=zero
537 ncell(i)=0
538 cycle
539 ENDIF
540 npts(i)= state_inimap_buf(i)%NUM_POINTS ;
541 npts_tot=npts_tot+npts(i)
542 len_(i)=state_inimap_buf(i)%LENGTH ;
543 len_tot=len_tot+len_(i)
544 ncell(i)= state_inimap_buf(i)%NUM_CENTROIDS ;
545 ncell_tot = ncell_tot + ncell(i)
546 ENDDO
547 ALLOCATE(work(npts_tot,5))
548 !stat_inimap1d_mp.F
549 !--gathering velocity into working_array
550 !
551 j=0
552 DO i=1,nspmd
553 DO k=1,npts(i)
554 j=j+1
555 work(j,1) = state_inimap_buf(i)%POS_NODES(k)
556 work(j,2) = state_inimap_buf(i)%POS2_NODES(k)
557 work(j,3) = state_inimap_buf(i)%VEL_NODES(k)
558 work(j,4) = state_inimap_buf(i)%VEL2_NODES(k)
559 work(j,5) = state_inimap_buf(i)%NODE_IDS(k)
560 ENDDO
561 ENDDO
562
563 !---SORTING : UNIQUE OUTPUT NOT DEPENDING ON DOMAIN DECOMPOSITION
564 IF(ALLOCATED(idx))DEALLOCATE(idx)
565 IF(.NOT.ALLOCATED(idx))ALLOCATE(idx(npts_tot))
566 DO k=1,npts_tot ; idx(k)=k; ENDDO
567 CALL quicksort(work(:,5), idx, 1, npts_tot)
568
569
570 !--- Remove duplicates (possible Common Nodes on Adjacent Domains)
571 ! STAGGERED SCHEME ONLY
572 !
573 IF(mlw /= 151)THEN
574 ALLOCATE(nodtag_g(npts_tot))
575 nodtag_g(1:npts_tot)=1
576 k=0
577 DO j=2,npts_tot
578 IF(work(j,5) == work(j-1,5))THEN
579 nodtag_g(j)=0
580 k=k+1
581 ENDIF
582 ENDDO
583 ELSE
584 k=npts_tot
585 ENDIF
586 !
587 !---store in relevant buffer (reallocate)
588 !
589 state_inimap_buf(1)%NUM_POINTS=k
590 IF(ALLOCATED(state_inimap_buf(1)%VEL_NODES))DEALLOCATE(state_inimap_buf(1)%VEL_NODES)
591 IF(ALLOCATED(state_inimap_buf(1)%VEL2_NODES))DEALLOCATE(state_inimap_buf(1)%VEL2_NODES)
592 IF(ALLOCATED(state_inimap_buf(1)%POS_NODES))DEALLOCATE(state_inimap_buf(1)%POS_NODES)
593 IF(ALLOCATED(state_inimap_buf(1)%POS2_NODES))DEALLOCATE(state_inimap_buf(1)%POS2_NODES)
594 IF(ALLOCATED(state_inimap_buf(1)%NODE_IDS))DEALLOCATE(state_inimap_buf(1)%NODE_IDS)
595 ALLOCATE(state_inimap_buf(1)%VEL_NODES(npts_tot), state_inimap_buf(1)%VEL2_NODES(npts_tot)) !k : npt_tot without duplicated
596 ALLOCATE(state_inimap_buf(1)%POS_NODES(npts_tot), state_inimap_buf(1)%POS2_NODES(npts_tot))
597 ALLOCATE(state_inimap_buf(1)%NODE_IDS(npts_tot))
598 j=0
599 DO k=1,npts_tot
600 IF(mlw /= 151)THEN
601 IF(nodtag_g(k)==0)cycle
602 ENDIF
603 j=j+1
604 state_inimap_buf(1)%POS_NODES(j)=work(idx(k),1)
605 state_inimap_buf(1)%POS2_NODES(j)=work(idx(k),2)
606 state_inimap_buf(1)%VEL_NODES(j)=work(idx(k),3)
607 state_inimap_buf(1)%VEL2_NODES(j)=work(idx(k),4)
608 state_inimap_buf(1)%NODE_IDS(j)=work(k,5) !already sorted
609 ENDDO
610 npts_tot = j
611 state_inimap_buf(1)%NUM_POINTS=npts_tot
612 IF(ALLOCATED(work))DEALLOCATE(work)
613 IF(ALLOCATED(nodtag_g))DEALLOCATE(nodtag_g)
614
615 nbmat=state_inimap_buf(1)%NSUBMAT
616 ALLOCATE(work(ncell_tot,3+4*nbmat))
617 !
618 !--gathering submaterial data into working_array (duplicates are not possible with centroids)
619 !
620 j=0
621 DO i=1,nspmd
622 DO k=1,ncell(i)
623 j=j+1
624 work(j,1) = state_inimap_buf(i)%POS_CENTROIDS(k)
625 work(j,2) = state_inimap_buf(i)%POS2_CENTROIDS(k)
626 work(j,3) = float(state_inimap_buf(i)%CELL_IDS(k)) ! bug in SP if CELL_ID > 16M
627 nbmat = state_inimap_buf(i)%NSUBMAT
628 DO jj=1,nbmat
629 work(j,3+ 4*(jj-1)+1) = state_inimap_buf(i)%SUBMAT(jj)%VFRAC(k)
630 work(j,3+ 4*(jj-1)+2) = state_inimap_buf(i)%SUBMAT(jj)%RHO(k)
631 work(j,3+ 4*(jj-1)+3) = state_inimap_buf(i)%SUBMAT(jj)%E(k)
632 work(j,3+ 4*(jj-1)+4) = state_inimap_buf(i)%SUBMAT(jj)%PRES(k)
633 ENDDO
634 ENDDO
635 ENDDO
636 !
637 !---store in relevant buffer (reallocate)
638 !
639 IF(ALLOCATED(state_inimap_buf(1)%POS_CENTROIDS))DEALLOCATE(state_inimap_buf(1)%POS_CENTROIDS)
640 IF(ALLOCATED(state_inimap_buf(1)%POS2_CENTROIDS))DEALLOCATE(state_inimap_buf(1)%POS2_CENTROIDS)
641 IF(ALLOCATED(state_inimap_buf(1)%CELL_IDS))DEALLOCATE(state_inimap_buf(1)%CELL_IDS)
642 nbmat = state_inimap_buf(1)%NSUBMAT
643 DO jj=1,nbmat
644 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%VFRAC))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%VFRAC)
645 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%RHO ))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%RHO)
646 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%E ))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%E)
647 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%PRES))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%PRES)
648 ENDDO
649 ALLOCATE(state_inimap_buf(1)%CELL_IDS(ncell_tot))
650 ALLOCATE(state_inimap_buf(1)%POS_CENTROIDS(ncell_tot))
651 ALLOCATE(state_inimap_buf(1)%POS2_CENTROIDS(ncell_tot))
652 DO jj=1,nbmat
653 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%VFRAC(ncell_tot))
654 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%RHO(ncell_tot))
655 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%E(ncell_tot))
656 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%PRES(ncell_tot))
657 ENDDO
658 !---SORTING : UNIQUE OUTPUT NOT DEPENDING ON DOMAIN DECOMPOSITION
659 IF(ALLOCATED(idx))DEALLOCATE(idx)
660 IF(.NOT.ALLOCATED(idx))ALLOCATE(idx(ncell_tot))
661 DO k=1,ncell_tot ; idx(k)=k; ENDDO
662 CALL quicksort(work(:,3), idx, 1, ncell_tot)
663
664 DO j=1,ncell_tot
665 state_inimap_buf(1)%POS_CENTROIDS(j)=work(idx(j),1)
666 state_inimap_buf(1)%POS2_CENTROIDS(j)=work(idx(j),2)
667 state_inimap_buf(1)%CELL_IDS(j)=int(work(j,3))
668 nbmat = state_inimap_buf(1)%NSUBMAT
669 DO jj=1,nbmat
670 state_inimap_buf(1)%SUBMAT(jj)%VFRAC(j)=work(idx(j),3+ 4*(jj-1)+1)
671 state_inimap_buf(1)%SUBMAT(jj)%RHO(j)=work(idx(j),3+ 4*(jj-1)+2)
672 state_inimap_buf(1)%SUBMAT(jj)%E(j)=work(idx(j),3+ 4*(jj-1)+3)
673 state_inimap_buf(1)%SUBMAT(jj)%PRES(j)=work(idx(j),3+ 4*(jj-1)+4)
674 ENDDO
675 ENDDO
676 state_inimap_buf(1)%NUM_CENTROIDS = ncell_tot
677 state_inimap_buf(1)%LENGTH = len_tot
678
679 endif! IF(ISPMD == 0 .AND. NSPMD > 1)THEN
680
681 IF(ispmd == 0)THEN
682 IF(ncell_tot == 0 .OR. len_tot == zero)THEN
683 CALL ancmsg(msgid=284,anmode=aninfo,c1=" -- 2D DOMAIN IS NOT DETECTED : CHECK X-PROJECTION")
684 return
685 ELSEIF(len_tot > 0 .AND. ncell_tot > 0)THEN
686 IF(lx/len_tot > em06)THEN
687 CALL ancmsg(msgid=284,anmode=aninfo,c1=" -- 2D DOMAIN IS NOT DETECTED.")
688 return
689 ENDIF
690 ENDIF
691 ENDIF
692
693C-----------------------------------------------
694C O u t p u t F i l e
695C-----------------------------------------------
696
697 !---OUTPUT FILE HEADER
698 !
699 IF(ispmd == 0)THEN
700 nbmat = state_inimap_buf(1)%NSUBMAT
701 WRITE(chstat,'(I4.4)')state_inimap_call_number
702
703 filnam=rootnam(1:rootlen)//'_2D_'//chstat//'.inimap'
704 shortname=rootnam(1:rootlen)//'_2D_'//chstat//'.inimap'
705 len = rootlen+11+4
706 len_tmp_name = outfile_name_len + len
707 tmp_name=outfile_name(1:outfile_name_len)//filnam(1:len)
708 DO i=1,len_tmp_name
709 ifilnam(i)=ichar(tmp_name(i:i))
710 END DO
711 CALL cur_fil_c(iuinimap)
712 CALL open_c(ifilnam,len_tmp_name,6)
713
714 CALL write_i_c(invers,1)
715 CALL write_db(tt,1)
716 CALL write_i_c(ncycle,1)
717 CALL write_i_c(ncell_tot,1)
718 CALL write_i_c(state_inimap_buf(1)%NUM_POINTS,1)
719 CALL write_i_c(nbmat,1)
720 ENDIF
721
722 IF(ispmd == 0)THEN
723 !--- OUTPUT FUNCTION FROM CELL DATA BUFFER ---!
724 nbmat = state_inimap_buf(1)%NSUBMAT
725 shift_cy = state_inimap_buf(1)%SHIFT_Cy
726 shift_ny = state_inimap_buf(1)%SHIFT_Ny
727 shift_cz = state_inimap_buf(1)%SHIFT_Cz
728 shift_nz = state_inimap_buf(1)%SHIFT_Nz
729 num_centroids = state_inimap_buf(1)%NUM_CENTROIDS
730
731 !---abscissa
732 CALL write_db(state_inimap_buf(1)%POS_CENTROIDS(1) ,num_centroids)
733 CALL write_db(state_inimap_buf(1)%POS2_CENTROIDS(1) ,num_centroids)
734
735 !---volume fractions
736 DO isubmat = 1,nbmat
737 CALL write_db(state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(1) ,num_centroids)
738 ENDDO
739
740 !---mass densities
741 DO isubmat = 1,nbmat
742 CALL write_db(state_inimap_buf(1)%SUBMAT(isubmat)%RHO(1) ,num_centroids)
743 ENDDO
744
745 !---pressure fraction
746 DO isubmat = 1,nbmat
747 CALL write_db(state_inimap_buf(1)%SUBMAT(isubmat)%PRES(1) ,num_centroids)
748 ENDDO
749
750 !--- OUTPUT VELOCITY FUNCTION ---!
751 !
752 IF(state_inimap_buf(1)%NUM_POINTS == state_inimap_buf(1)%NUM_CENTROIDS)THEN
753 CALL write_db(state_inimap_buf(1)%VEL_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
754 CALL write_db(state_inimap_buf(1)%VEL2_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
755 ELSE
756 CALL write_db(state_inimap_buf(1)%POS_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
757 CALL write_db(state_inimap_buf(1)%POS2_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
758 CALL write_db(state_inimap_buf(1)%VEL_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
759 CALL write_db(state_inimap_buf(1)%VEL2_NODES(1) ,state_inimap_buf(1)%NUM_POINTS)
760 ENDIF
761 ENDIF
762
763C-----------------------------------------------
764C D e a l l o c a t e & C l o s e
765C-----------------------------------------------
766 IF(ispmd == 0)THEN
767
768 !---OUTPUT FILE : FOOTER & CLOSE
769 shortname=shortname//'.gz'
770 WRITE (iout,500) shortname(1:len_trim(trim(shortname)))
771 WRITE (istdo,500) shortname(1:len_trim(trim(shortname)))
772 CALL close_c()
773
774 !---DEALLOCATE
775 IF(ALLOCATED(get_cell_fom_centroid))DEALLOCATE(get_cell_fom_centroid)
776 DO jj=1,nspmd
777 nbmat = state_inimap_buf(jj)%NSUBMAT
778 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT))THEN
779 DO i=1,nbmat
780 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%VFRAC))DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%VFRAC)
781 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%RHO)) DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%RHO)
782 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%E)) DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%E)
783 ENDDO
784 ENDIF
785 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT ))DEALLOCATE(state_inimap_buf(jj)%SUBMAT)
786 IF(ALLOCATED(state_inimap_buf(jj)%POS_NODES ))DEALLOCATE(state_inimap_buf(jj)%POS_NODES)
787 IF(ALLOCATED(state_inimap_buf(jj)%VEL_NODES ))DEALLOCATE(state_inimap_buf(jj)%VEL_NODES)
788 IF(ALLOCATED(state_inimap_buf(jj)%POS2_NODES ))DEALLOCATE(state_inimap_buf(jj)%POS2_NODES)
789 IF(ALLOCATED(state_inimap_buf(jj)%VEL2_NODES ))DEALLOCATE(state_inimap_buf(jj)%VEL2_NODES)
790 IF(ALLOCATED(state_inimap_buf(jj)%NODE_IDS ))DEALLOCATE(state_inimap_buf(jj)%NODE_IDS)
791 IF(ALLOCATED(state_inimap_buf(jj)%POS_CENTROIDS))DEALLOCATE(state_inimap_buf(jj)%POS_CENTROIDS)
792 IF(ALLOCATED(state_inimap_buf(jj)%POS_CENTROIDS))DEALLOCATE(state_inimap_buf(jj)%POS2_CENTROIDS)
793 IF(ALLOCATED(state_inimap_buf(jj)%CELL_IDS))DEALLOCATE(state_inimap_buf(jj)%CELL_IDS)
794 ENDDO
795
796 ENDIF
797
798 IF(ALLOCATED(state_inimap_buf))DEALLOCATE(state_inimap_buf)
799
800C-----------------------------------------------
801C O u t p u t F o r m a t
802C-----------------------------------------------
803 500 FORMAT (4x,' STATE FILE:',1x,a,' WRITTEN')
804C-----------------------------------------------
805 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
inoutfile_mod
Definition inoutfile_mod.F:96
inoutfile_mod::outfile_name
character(len=outfile_char_len) outfile_name
Definition inoutfile_mod.F:111
inoutfile_mod::outfile_name_len
integer outfile_name_len
Definition inoutfile_mod.F:109
message_mod
Definition message_mod.F:1257
state_inimap_mod
Definition state_inimap_mod.F:38
state_inimap_mod::state_inimap_call_number
integer state_inimap_call_number
Definition state_inimap_mod.F:40
state_inimap_mod::state_inimap_buf
type(map_struct), dimension(:), allocatable state_inimap_buf
Definition state_inimap_mod.F:84
quicksort_i2
recursive subroutine quicksort_i2(a, idx, first, last)
Definition quicksort.F:153
quicksort
recursive subroutine quicksort(a, idx, first, last)
Definition quicksort.F:34
spmd_state_inimap2d_exch_data
subroutine spmd_state_inimap2d_exch_data()
Definition spmd_state_inimap2d_exch_data.F:34
spmd_state_inimap_exch_siz
subroutine spmd_state_inimap_exch_siz()
Definition spmd_state_inimap_exch_siz.F:36
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
write_db
subroutine write_db(a, n)
Definition write_db.F:142
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645
close_c
void close_c()
Definition write_routines.c:298
cur_fil_c
void cur_fil_c(int *nf)
Definition write_routines.c:477
open_c
void open_c(int *ifil, int *len, int *mod)
Definition write_routines.c:180