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 47 of file stat_inimap2d_file_spmd.F.

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