OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_inimap1d_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_inimap1d_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_inimap1d_spmd()

subroutine stat_inimap1d_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 41 of file stat_inimap1d_spmd.F.

46C-----------------------------------------------
47C Description
48C-----------------------------------------------
49C This subroutine is generating mapping data to be used with /INIMAP1D option.
50C include file is incremented starting from ROOT_1D_0001.inimap
51C It contains 1D fonctions for submaterial data (volume fraction, mass density, energy density)
52C and also function for global velocity
53C User can use the generated file in a second run using #include command in the new Starter input file (target mesh)
54C-----------------------------------------------
55C M o d u l e s
56C-----------------------------------------------
57 USE message_mod
58 USE elbufdef_mod
59 USE state_inimap_mod
60 USE multi_fvm_mod
61 USE multimat_param_mod , ONLY : m51_n0phas, m51_nvphas
62 USE matparam_def_mod, ONLY : matparam_struct_
63 use element_mod , only : nixs,nixq,nixtg
64C-----------------------------------------------
65C I m p l i c i t T y p e s
66C-----------------------------------------------
67#include "implicit_f.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "com01_c.inc"
72#include "com04_c.inc"
73#include "com08_c.inc"
74#include "param_c.inc"
75#include "scr03_c.inc"
76#include "scr17_c.inc"
77#include "task_c.inc"
78#include "units_c.inc"
79#include "chara_c.inc"
80C-----------------------------------------------
81C D u m m y A r g u m e n t s
82C-----------------------------------------------
83 INTEGER,INTENT(IN) :: ITAB(NUMNOD), IPART(LIPART1,*),IGEO(NPROPGI,NUMGEO),IXS(NIXS,NUMELS), IPART_STATE(NPART)
84 INTEGER,INTENT(IN) :: IPARG(NPARG,*),IXQ(NIXQ,NUMELQ),IXTG(NIXTG,NUMELTG)
85 INTEGER, INTENT(INOUT) :: NODTAG(NUMNOD),IPM(NPROPMI,*)
86 INTEGER, TARGET :: IPARTS(*),IPARTQ(*),IPARTTG(*)
87 my_real,INTENT(IN) :: x(3,numnod),v(3,numnod)
88 my_real, INTENT(IN), TARGET :: bufmat(*)
89 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET, INTENT(IN) :: ELBUF_TAB
90 TYPE(MULTI_FVM_STRUCT), INTENT(IN) :: MULTI_FVM
91 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
92C-----------------------------------------------
93C L o c a l V a r i a b l e s
94C-----------------------------------------------
95 INTEGER I, N, JJ,J, IPRT, K, KK
96 INTEGER NG, NEL, NFT, LFT, LLT, ITY, ISOLNOD,NPT
97 INTEGER NUM_CENTROIDS, IPOS,MLW,NBMAT,NB2,ISUBMAT,NNOD,NNOD2
98 INTEGER NUVAR
99 TYPE(G_BUFEL_) ,POINTER :: GBUF
100 my_real p0(3),p0_inf(3),p0_sup(3),shift_c,shift_n,length
101 my_real max_xc,max_yc,max_zc,min_xc,min_yc,min_zc
102 my_real lx,ly,lz
103 my_real dx,dy,dz
104 my_real dotprod,tol,xyz(3),vel(3),dist,vect(3)
105 CHARACTER FILNAM*100, CHSTAT*4
106 INTEGER XMIN_CELL_ID,YMIN_CELL_ID,ZMIN_CELL_ID,XMAX_CELL_ID,YMAX_CELL_ID,ZMAX_CELL_ID
107 INTEGER IS_ITY_1, IS_ITY_2, IS_ITY_7, LAST_CELL,FIRST_CELL,IMAT,NPAR,IADBUF
108 INTEGER, ALLOCATABLE, DIMENSION(:) :: IDX
109 INTEGER, POINTER,DIMENSION(:) :: IPART_PTR
110 my_real, POINTER,DIMENSION(:) :: uparam
111 TYPE(BUF_MAT_) ,POINTER :: MBUF
112 my_real, ALLOCATABLE, DIMENSION(:,:) :: map_nodes
113 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: GET_CELL_FOM_CENTROID !(NG,I+NFT)
114 INTEGER NPTS(NSPMD),NCELL(NSPMD),NPTS_TOT,NCELL_TOT
115 my_real, DIMENSION(:,:), ALLOCATABLE :: work
116 INTEGER, DIMENSION(:), ALLOCATABLE :: WORK_INDX
117 my_real :: len_(nspmd),len_tot,shift_c_min,shift_n_min
118 INTEGER :: IDX1(21),IDX2(21),IDX3(21)
119C-----------------------------------------------
120C S o u r c e L i n e s
121C-----------------------------------------------
122
123 !---INITIALIZATION
124 !
125 state_inimap_call_number = state_inimap_call_number +1 !number of written files ROOT_INIMAP_00**.rad
126 num_centroids = 0
127 mlw=0
128 !box containing user domain :
129 min_xc = ep20
130 min_yc = ep20
131 min_zc = ep20
132 max_xc = -ep20
133 max_yc = -ep20
134 max_zc = -ep20
135 !detecting elem types to manager error messages :
136 is_ity_1 = 0
137 is_ity_2 = 0
138 is_ity_7 = 0
139
140 !---ALLOCATIONS
141 !
142 IF(.NOT.(ALLOCATED(state_inimap_buf))) THEN
143 IF(ispmd/=0)THEN
144 ALLOCATE(state_inimap_buf(1))
145 ELSE
146 ALLOCATE(state_inimap_buf(nspmd)) !process 0 will gather all data
147 ENDIF
148 ENDIF
149
150 !---enumaration : elem types and box dimension
151 !
152 DO ng=1,ngroup
153 ity =iparg(5,ng)
154 isolnod = iparg(28,ng)
155 nel =iparg(2,ng)
156 nft =iparg(3,ng)
157 gbuf => elbuf_tab(ng)%GBUF
158 mlw = iparg(1,ng)
159 lft=1
160 llt=nel
161 npt=0
162 IF(ity == 1) THEN
163 !---bricks
164 is_ity_1=1
165 npt=isolnod
166 ipart_ptr => iparts(1:numels)
167 ELSEIF(ity == 2)THEN
168 !---quads
169 is_ity_2=1
170 npt=4
171 ipart_ptr => ipartq(1:numelq)
172 ELSEIF(ity == 7 .AND. n2d /= 0)THEN
173 !---Triangles
174 is_ity_7=1
175 npt=3
176 ipart_ptr => iparttg(1:numeltg)
177 ENDIF
178 IF(npt /= 0)THEN
179 DO i=lft,llt
180 n = i + nft
181 iprt=ipart_ptr(n)
182 imat =ipart(1,iprt)
183 IF(ipart_state(iprt)==0)cycle
184 num_centroids = num_centroids +1
185 IF(is_ity_1==1)THEN
186 p0(1) = sum( x(1,ixs(2:9,n)) ) / npt
187 p0(2) = sum( x(2,ixs(2:9,n)) ) / npt
188 p0(3) = sum( x(3,ixs(2:9,n)) ) / npt
189 ELSEIF(is_ity_2==1)THEN
190 p0(1) = sum( x(1,ixq(2:5,n)) ) / npt
191 p0(2) = sum( x(2,ixq(2:5,n)) ) / npt
192 p0(3) = sum( x(3,ixq(2:5,n)) ) / npt
193 ENDIF
194 IF(min_xc>p0(1))THEN
195 min_xc=p0(1)
196 xmin_cell_id = n
197 ENDIF
198 IF(min_yc>p0(2))THEN
199 min_yc=p0(2)
200 ymin_cell_id = n
201 ENDIF
202 IF(min_zc>p0(3))THEN
203 min_zc=p0(3)
204 zmin_cell_id = n
205 ENDIF
206 IF(max_xc<p0(1))THEN
207 max_xc=p0(1)
208 xmax_cell_id = n
209 ENDIF
210 IF(max_yc<p0(2))THEN
211 max_yc=p0(2)
212 ymax_cell_id = n
213 ENDIF
214 IF(max_zc<p0(3))THEN
215 max_zc=p0(3)
216 zmax_cell_id = n
217 ENDIF
218 END DO
219 ELSE
220 !no related cells: bricks, quads, and triangles only
221 END IF
222 END do! next NG
223
224 !---NUMBERING :
225 ! +--CENTROIDS
226 state_inimap_buf(1)%NUM_CENTROIDS = num_centroids
227 state_inimap_buf(1)%NUM_POINTS = 0
228 ! +--FIRST ESTIMATION OF NODE NUMBER (DUPLICATED PROJECTIONS AT THIS STEP)
229 nnod=0
230 DO i=1,numnod
231 IF(nodtag(i) == 1)THEN
232 nnod=nnod+1
233 ENDIF
234 ENDDO
235
236 !---ANOTHER ALLOCATIONS
237 !
238 IF(.NOT.ALLOCATED(map_nodes))ALLOCATE(map_nodes(3,nnod))
239 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_CENTROIDS))ALLOCATE(state_inimap_buf(1)%POS_CENTROIDS(num_centroids))
240 IF(.NOT.ALLOCATED(get_cell_fom_centroid))THEN
241 ALLOCATE(get_cell_fom_centroid(2,num_centroids))
242 ENDIF
243
244 lx=zero
245 ly=zero
246 lz=zero
247 IF(num_centroids > 0)THEN
248 !---BOX CONTAINING USER-1D-DOMAIN & BUILDING 1D AXIS
249 ! use centroids otherwise with spmd decomposition 1d portion may be smaller than orthogonal directions. (S >> dl)
250 lx=max_xc-min_xc
251 ly=max_yc-min_yc
252 lz=max_zc-min_zc
253 vect(1:3)=(/lx,ly,lz/)
254 !---first and last cell along this user 1D domain
255 ipos = maxloc(vect(1:3),1)
256 SELECT CASE(ipos)
257 CASE(1)
258 first_cell = xmin_cell_id
259 last_cell = xmax_cell_id
260 CASE(2)
261 first_cell = ymin_cell_id
262 last_cell = ymax_cell_id
263 CASE(3)
264 first_cell = zmin_cell_id
265 last_cell = zmax_cell_id
266 END SELECT
267 !---first and last centroid position
268 IF(is_ity_1==1)THEN
269 p0_inf(1) = sum( x(1,ixs(2:9,first_cell)) ) / npt
270 p0_inf(2) = sum( x(2,ixs(2:9,first_cell)) ) / npt
271 p0_inf(3) = sum( x(3,ixs(2:9,first_cell)) ) / npt
272 p0_sup(1) = sum( x(1,ixs(2:9,last_cell)) ) / npt
273 p0_sup(2) = sum( x(2,ixs(2:9,last_cell)) ) / npt
274 p0_sup(3) = sum( x(3,ixs(2:9,last_cell)) ) / npt
275 ELSEIF(is_ity_2==1)THEN
276 p0_inf(1) = sum( x(1,ixq(2:5,first_cell)) ) / npt
277 p0_inf(2) = sum( x(2,ixq(2:5,first_cell)) ) / npt
278 p0_inf(3) = sum( x(3,ixq(2:5,first_cell)) ) / npt
279 p0_sup(1) = sum( x(1,ixq(2:5,last_cell)) ) / npt
280 p0_sup(2) = sum( x(2,ixq(2:5,last_cell)) ) / npt
281 p0_sup(3) = sum( x(3,ixq(2:5,last_cell)) ) / npt
282 ENDIF
283 !---first and last centroid position are determining 1D axis :
284 vect(1:3)=(/p0_sup(1)-p0_inf(1),p0_sup(2)-p0_inf(2),p0_sup(3)-p0_inf(3)/)
285 lx=vect(1)
286 ly=vect(2)
287 lz=vect(3)
288 length = sqrt(vect(1)*vect(1) + vect(2)*vect(2) + vect(3)*vect(3)) !1d axis length (needed to normalize following dot products)
289 shift_c=zero
290 IF(length > zero)shift_c = (p0_inf(1)*lx + p0_inf(2)*ly + p0_inf(3)*lz) / length !distance from origin at first centroid position
291 state_inimap_buf(1)%SHIFT_Cy = shift_c
292 state_inimap_buf(1)%SHIFT_Cz = zero
293 state_inimap_buf(1)%LENGTH = length
294 ELSE
295 state_inimap_buf(1)%SHIFT_Cy = zero
296 state_inimap_buf(1)%SHIFT_Cz = zero
297 state_inimap_buf(1)%LENGTH = zero
298 ENDIF
299 !---ERROR MESSAGES
300 !
301 IF(is_ity_7 > 0)THEN
302 CALL ancmsg(msgid=284,anmode=aninfo,c1=" -- 1D DOMAIN MUST BE MESHED WITH BRICKS OR QUADS ONLY")
303 return
304 ENDIF
305
306 !---STARTING POINT OF FIRST NODE IN GENERAL FRAME (SHIFT_N)
307 ! SHIFT_N : nodal posisiton (first node along axis)
308 ! SHIFT_C : cell centroid position (first centroid along axis)
309 ! by nature : SHIFT_N < SHIFT_C
310 !
311 IF(is_ity_1==1)THEN
312 dx = x(1,ixs(2,first_cell))
313 dy = x(2,ixs(2,first_cell))
314 dz = x(3,ixs(2,first_cell))
315 DO jj=3,npt
316 IF(x(1,ixs(jj,first_cell)) < dx)dx=x(1,ixs(jj,first_cell))
317 IF(x(2,ixs(jj,first_cell)) < dy)dy=x(2,ixs(jj,first_cell))
318 IF(x(3,ixs(jj,first_cell)) < dz)dz=x(3,ixs(jj,first_cell))
319 ENDDO
320 ELSEIF(is_ity_2==1)THEN
321 dx = x(1,ixq(2,first_cell))
322 dy = x(2,ixq(2,first_cell))
323 dz = x(3,ixq(2,first_cell))
324 DO jj=3,npt
325 IF(x(1,ixq(jj,first_cell)) < dx)dx=x(1,ixq(jj,first_cell))
326 IF(x(2,ixq(jj,first_cell)) < dx)dy=x(2,ixq(jj,first_cell))
327 IF(x(3,ixq(jj,first_cell)) < dx)dz=x(3,ixq(jj,first_cell))
328 ENDDO
329 ENDIF
330 !first point projection on 1d axis
331 shift_n = zero
332 IF(length > zero)shift_n=(dx*lx + dy*ly + dz*lz) / length
333 state_inimap_buf(1)%SHIFT_Ny = shift_n
334 state_inimap_buf(1)%SHIFT_Nz = zero
335
336 !---ABSCISSA : CENTROIDS POSITION LIST ( STATE_INIMAP_BUF(1)%POS_CENTROIDS(1:NUM_CENTROIDS) )
337 !
338 k=1
339 DO ng=1,ngroup
340 ity =iparg(5,ng)
341 isolnod = iparg(28,ng)
342 nel =iparg(2,ng)
343 nft =iparg(3,ng)
344 gbuf => elbuf_tab(ng)%GBUF
345 mlw = iparg(1,ng)
346 lft=1
347 llt=nel
348 IF(npt /= 0)THEN
349 DO i=lft,llt
350 n = i + nft
351 iprt=ipart_ptr(n)
352 IF(ipart_state(iprt)==0)cycle
353 IF(is_ity_1==1)THEN
354 p0(1) = sum( x(1,ixs(2:9,n)) ) / npt
355 p0(2) = sum( x(2,ixs(2:9,n)) ) / npt
356 p0(3) = sum( x(3,ixs(2:9,n)) ) / npt
357 ELSEIF(is_ity_2==1)THEN
358 p0(1) = sum( x(1,ixq(2:5,n)) ) / npt
359 p0(2) = sum( x(2,ixq(2:5,n)) ) / npt
360 p0(3) = sum( x(3,ixq(2:5,n)) ) / npt
361 ENDIF
362 dx = p0(1)-p0_inf(1)
363 dy = p0(2)-p0_inf(2)
364 dz = p0(3)-p0_inf(3)
365 !DIST = SQRT(DX*DX+DY*DY+DZ*DZ)
366 dotprod = zero
367 IF(length > zero)dotprod = (lx*dx + ly*dy + lz*dz) / length
368 state_inimap_buf(1)%POS_CENTROIDS(k) = dotprod + state_inimap_buf(1)%SHIFT_Cy
369 get_cell_fom_centroid(1,k) = ng
370 get_cell_fom_centroid(2,k) = i
371 k=k+1
372 END DO
373 END IF
374 END do! next NG
375 !---ABSCISSA : CENTROIDS POSITION - SORTING
376 IF(.NOT.ALLOCATED(idx))ALLOCATE(idx(num_centroids))
377 DO k=1,num_centroids ; idx(k)=k; ENDDO
378 IF(num_centroids>0)CALL quicksort(state_inimap_buf(1)%POS_CENTROIDS(:), idx, 1, num_centroids)
379
380 !---CELL DATA TREATMENT
381 ! storing submaterial data : vfrac,rho,E
382 !
383 IF(num_centroids > 0)THEN
384 IF(mlw==151)THEN
385 nbmat = multi_fvm%NBMAT
386 ELSEIF(mlw==51)THEN
387 nbmat = 4
388 ELSE
389 nbmat = 1
390 ENDIF
391 state_inimap_buf(1)%MLW = mlw
392 state_inimap_buf(1)%NSUBMAT = nbmat
393 ALLOCATE(state_inimap_buf(1)%SUBMAT(nbmat))
394 DO i=1,nbmat
395 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%VFRAC(num_centroids))
396 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%RHO(num_centroids))
397 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%E(num_centroids))
398 ALLOCATE(state_inimap_buf(1)%SUBMAT(i)%PRES(num_centroids))
399 ENDDO
400 IF(mlw==151)THEN
401 !velocities
402 state_inimap_buf(1)%NUM_POINTS = num_centroids
403 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_NODES))ALLOCATE(state_inimap_buf(1)%POS_NODES(num_centroids))
404 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL_NODES))ALLOCATE(state_inimap_buf(1)%VEL_NODES(num_centroids))
405 DO k=1, num_centroids
406 ng = get_cell_fom_centroid(1,idx(k))
407 i = get_cell_fom_centroid(2,idx(k))
408 nft = iparg(3,ng)
409 state_inimap_buf(1)%POS_NODES(k) = state_inimap_buf(1)%POS_CENTROIDS(k)
410 xyz(1:3) = multi_fvm%VEL(1:3,i+nft)
411 dotprod=zero
412 IF(length > zero)dotprod = (lx*xyz(1) + ly*xyz(2) + lz*xyz(3)) / length
413 state_inimap_buf(1)%VEL_NODES(k) = dotprod
414 ENDDO
415 !submat
416 DO isubmat=1,nbmat
417 DO k=1, num_centroids
418 ng = get_cell_fom_centroid(1,idx(k))
419 i = get_cell_fom_centroid(2,idx(k))
420 nft = iparg(3,ng)
421 state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(k) = multi_fvm%PHASE_ALPHA(isubmat,i+nft)
422 state_inimap_buf(1)%SUBMAT(isubmat)%RHO(k) = multi_fvm%PHASE_RHO(isubmat,i+nft)
423 state_inimap_buf(1)%SUBMAT(isubmat)%E(k) = multi_fvm%PHASE_EINT(isubmat,i+nft)
424 state_inimap_buf(1)%SUBMAT(isubmat)%PRES(k) = multi_fvm%PRES(i+nft)
425 ENDDO
426 ENDDO
427 ELSEIF(mlw==51)THEN
428 nb2=0
429 DO isubmat=1,nbmat
430 DO k=1, num_centroids
431 ng = get_cell_fom_centroid(1,idx(k))
432 i = get_cell_fom_centroid(2,idx(k))
433 nft = iparg(3,ng)
434 nel = iparg(2,ng)
435 n = i + nft
436 iprt=ipart_ptr(n)
437 imat =ipart(1,iprt)
438 IF(mat_param(imat)%MULTIMAT%MID(isubmat) == 0)EXIT !submaterial not defined.
439 nb2=max(nb2,ipm(5,imat))
440 iadbuf = ipm(7,imat)
441 npar = ipm(9,imat)
442 nuvar = ipm(8,imat)
443 uparam => bufmat(iadbuf:iadbuf+npar-1)
444 kk = m51_n0phas + (uparam(276+isubmat)-1)*m51_nvphas
445 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
446 state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(k) = mbuf%VAR(nel*(01+kk-1)+i)
447 state_inimap_buf(1)%SUBMAT(isubmat)%RHO(k) = mbuf%VAR(nel*(12+kk-1)+i)
448 state_inimap_buf(1)%SUBMAT(isubmat)%E(k) = mbuf%VAR(nel*(08+kk-1)+i)
449 state_inimap_buf(1)%SUBMAT(isubmat)%PRES(k) = mbuf%VAR(nel*(18+kk-1)+i)
450 ENDDO
451 ENDDO
452 state_inimap_buf(1)%NSUBMAT = nb2
453 ELSE
454 DO k=1, num_centroids
455 ng = get_cell_fom_centroid(1,idx(k))
456 nel = iparg(2,ng)
457 i = get_cell_fom_centroid(2,idx(k))
458 gbuf => elbuf_tab(ng)%GBUF
459 state_inimap_buf(1)%SUBMAT(1)%VFRAC(k) = 1.d00
460 state_inimap_buf(1)%SUBMAT(1)%RHO(k) = gbuf%RHO(i)
461 state_inimap_buf(1)%SUBMAT(1)%E(k) = gbuf%EINT(i)
462 state_inimap_buf(1)%SUBMAT(1)%PRES(k) = -third * (gbuf%SIG(i) + gbuf%SIG(i + nel) + gbuf%SIG(i + 2 * nel))
463 ENDDO
464 ENDIF
465 ENDIF
466
467 !---VELOCITY TREATMENT FOR STAGGERED SCHEME
468 ! law 51 only
469 !
470 ! MAP_NODES(1,...) : node_id
471 ! MAP_NODS (2, ...): 1D-Position
472 ! MAP_NODES(3,...) : vel_1d-value
473 !
474 IF(num_centroids > 0)THEN
475 IF(mlw /= 151)THEN
476 k=1
477 DO i=1,numnod
478 IF(nodtag(i) == 1)THEN
479 map_nodes(1,k)=i
480 xyz(1:3)=x(1:3,i)
481 dotprod=zero
482 IF(length > zero)dotprod = (lx*xyz(1) + ly*xyz(2) + lz*xyz(3)) / length
483 map_nodes(2,k)=dotprod
484 k=k+1
485 ENDIF
486 ENDDO
487 IF(ALLOCATED(idx))DEALLOCATE(idx)
488 ALLOCATE(idx(nnod))
489 DO k=1,nnod ; idx(k)=k; ENDDO
490 CALL quicksort(map_nodes(2,:), idx, 1, nnod)
491 tol=em10*length
492 !---check duplicates and remove
493 nnod2=nnod
494 DO i=2,nnod
495 dist = abs(map_nodes(2,i)-map_nodes(2,i-1))
496 IF(dist <= tol) map_nodes(1,idx(i)) = zero
497 ENDDO
498 k=0
499 DO i=1,nnod
500 IF(map_nodes(1,idx(i)) /= zero)THEN
501 k=k+1
502 ENDIF
503 ENDDO
504 !---VELOCITY : WRITE IN DOMAIN BUFFER (SORTED)
505 IF(.NOT.ALLOCATED(state_inimap_buf(1)%POS_NODES))ALLOCATE(state_inimap_buf(1)%POS_NODES(k))
506 IF(.NOT.ALLOCATED(state_inimap_buf(1)%VEL_NODES))ALLOCATE(state_inimap_buf(1)%VEL_NODES(k))
507 k=0
508 DO i=1,nnod
509 IF(map_nodes(1,idx(i)) /= zero)THEN
510 k=k+1
511 state_inimap_buf(1)%POS_NODES(k) = map_nodes(2,i) !already sorted k<=i nothing is erased
512 vel(1:3)=v(1:3,int(map_nodes(1,idx(i))))
513 dotprod=zero
514 IF(length > zero)dotprod = (lx*vel(1) + ly*vel(2) + lz*vel(3)) / length
515 state_inimap_buf(1)%VEL_NODES(k)=dotprod
516 ENDIF
517 ENDDO
518 state_inimap_buf(1)%NUM_POINTS=k
519 ELSE
520
521 ENDIF
522 ENDIF
523
524C-----------------------------------------------
525C S P M D E x c h a n g e
526C-----------------------------------------------
527 IF(nspmd > 1)THEN
528 CALL spmd_state_inimap_exch_siz()
529 CALL spmd_state_inimap1d_exch_data()
530 !
531 IF(ispmd == 0)THEN
532 shift_c_min = state_inimap_buf(1)%SHIFT_Cy
533 shift_n_min = state_inimap_buf(1)%SHIFT_Ny
534 DO i=2,nspmd
535 IF(state_inimap_buf(i)%NUM_CENTROIDS==0)cycle
536 shift_c_min =min(shift_c_min, state_inimap_buf(i)%SHIFT_Cy)
537 shift_n_min =min(shift_n_min, state_inimap_buf(i)%SHIFT_Ny)
538 ENDDO
539 state_inimap_buf(1)%SHIFT_Cy = shift_c_min
540 state_inimap_buf(1)%SHIFT_Ny = shift_n_min
541 ENDIF
542 ENDIF
543
544C-----------------------------------------------
545C S P M D - G a t h e r i n g & S o r t i n g
546C-----------------------------------------------
547 ncell_tot = state_inimap_buf(1)%NUM_CENTROIDS
548 len_tot = state_inimap_buf(1)%LENGTH
549 IF(ispmd == 0 .AND. nspmd > 1)THEN
550 !--cumulated dimensions
551 !
552 npts_tot = 0
553 ncell_tot = 0
554 len_tot = zero
555 DO i=1,nspmd
556 IF(state_inimap_buf(i)%NUM_CENTROIDS==0)THEN
557 npts(i)=0
558 len_(i)=zero
559 ncell(i)=0
560 cycle
561 ENDIF
562 npts(i)= state_inimap_buf(i)%NUM_POINTS ;
563 npts_tot=npts_tot+npts(i)
564 len_(i)=state_inimap_buf(i)%LENGTH ;
565 len_tot=len_tot+len_(i)
566 ncell(i)= state_inimap_buf(i)%NUM_CENTROIDS ;
567 ncell_tot = ncell_tot + ncell(i)
568 ENDDO
569 ALLOCATE(work(npts_tot,3),work_indx(npts_tot))
570 !stat_inimap1d_mp.F
571 !--gathering velocity into working_array
572 !
573 j=0
574 DO i=1,nspmd
575 DO k=1,npts(i)
576 j=j+1
577 work(j,1) = state_inimap_buf(i)%POS_NODES(k)
578 work(j,3) = state_inimap_buf(i)%VEL_NODES(k) !tmp
579 ENDDO
580 ENDDO
581 !
582 !sorting velocity
583 !
584 work_indx(1:npts_tot) = (/(j,j=1,npts_tot)/)
585 CALL quicksort(work(:,1), work_indx, 1, npts_tot)
586 !sort velocity consequently
587 DO i=1,npts_tot
588 work(i,2)=work(work_indx(i),3) !sorted vel
589 ENDDO
590 tol=em10*len_tot
591 work_indx(1:npts_tot) = 0
592 !
593 !--- Remove duplicates (possible Common Nodes on Adjacent Domains)
594 ! STAGGERED SCHEME ONLY
595 !
596 IF(mlw /= 151)THEN
597 DO i=2,npts_tot
598 dist = abs(work(i,1)-work(i-1,1))
599 IF(dist <= tol) THEN
600 work_indx(i) = 1
601 ENDIF
602 ENDDO
603 k=0
604 DO i=1,npts_tot
605 IF(work_indx(i) ==0 )THEN
606 k=k+1
607 work(k,1)=work(i,1) !abscicca
608 work(k,2)=work(i,2) !ordinates
609 ENDIF
610 ENDDO
611 DO i=k+1,npts_tot ; work(i,1:2)=zero ; ENDDO
612 npts_tot=k
613 ENDIF
614 !
615 !---store in relevant buffer (reallocate)
616 !
617 IF(ALLOCATED(state_inimap_buf(1)%VEL_NODES))DEALLOCATE(state_inimap_buf(1)%VEL_NODES)
618 IF(ALLOCATED(state_inimap_buf(1)%POS_NODES))DEALLOCATE(state_inimap_buf(1)%POS_NODES)
619 ALLOCATE(state_inimap_buf(1)%VEL_NODES(npts_tot))
620 ALLOCATE(state_inimap_buf(1)%POS_NODES(npts_tot))
621 state_inimap_buf(1)%NUM_POINTS=npts_tot
622 state_inimap_buf(1)%POS_NODES(1:npts_tot)=work(1:npts_tot,1)
623 state_inimap_buf(1)%VEL_NODES(1:npts_tot)=work(1:npts_tot,2)
624 IF(ALLOCATED(work))DEALLOCATE(work)
625 IF(ALLOCATED(work_indx))DEALLOCATE(work_indx)
626
627
628 nbmat=1
629 DO i=1,nspmd
630 nbmat=max(nbmat,state_inimap_buf(i)%NSUBMAT)
631 ENDDO
632 ALLOCATE(work(ncell_tot,1+4*nbmat))
633 ALLOCATE(work_indx(ncell_tot))
634 !
635 !--gathering submaterial data into working_array (duplicates are not possible with centroids)
636 !
637 j=0
638 DO i=1,nspmd
639 DO k=1,ncell(i)
640 j=j+1
641 work(j,1) = state_inimap_buf(i)%POS_CENTROIDS(k)
642 nbmat = state_inimap_buf(i)%NSUBMAT
643 DO jj=1,nbmat
644 work(j,1+ 4*(jj-1)+1) = state_inimap_buf(i)%SUBMAT(jj)%VFRAC(k)
645 work(j,1+ 4*(jj-1)+2) = state_inimap_buf(i)%SUBMAT(jj)%RHO(k)
646 work(j,1+ 4*(jj-1)+3) = state_inimap_buf(i)%SUBMAT(jj)%E(k)
647 work(j,1+ 4*(jj-1)+4) = state_inimap_buf(i)%SUBMAT(jj)%PRES(k)
648 ENDDO
649 ENDDO
650 ENDDO
651 !
652 !sorting
653 !
654 work_indx(1:ncell_tot) = (/(j,j=1,ncell_tot)/)
655 CALL quicksort(work(:,1), work_indx, 1, ncell_tot)
656 !
657 !---store in relevant buffer (reallocate)
658 !
659 IF(ALLOCATED(state_inimap_buf(1)%POS_CENTROIDS))DEALLOCATE(state_inimap_buf(1)%POS_CENTROIDS)
660 nbmat = state_inimap_buf(1)%NSUBMAT
661 DO jj=1,nbmat
662 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%VFRAC))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%VFRAC)
663 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%RHO))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%RHO)
664 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%E))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%E)
665 IF(ALLOCATED(state_inimap_buf(1)%SUBMAT(jj)%PRES))DEALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%PRES)
666 ENDDO
667 ALLOCATE(state_inimap_buf(1)%POS_CENTROIDS(ncell_tot))
668 DO jj=1,nbmat
669 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%VFRAC(ncell_tot))
670 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%RHO(ncell_tot))
671 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%E(ncell_tot))
672 ALLOCATE(state_inimap_buf(1)%SUBMAT(jj)%PRES(ncell_tot))
673 ENDDO
674 DO j=1,ncell_tot
675 state_inimap_buf(1)%POS_CENTROIDS(j)=work(j,1) !-SHIFT_C_MIN
676 DO jj=1,nbmat
677 state_inimap_buf(1)%SUBMAT(jj)%VFRAC(j)=work(work_indx(j),1+ 4*(jj-1)+1)
678 state_inimap_buf(1)%SUBMAT(jj)%RHO(j) =work(work_indx(j),1+ 4*(jj-1)+2)
679 state_inimap_buf(1)%SUBMAT(jj)%E(j) =work(work_indx(j),1+ 4*(jj-1)+3)
680 state_inimap_buf(1)%SUBMAT(jj)%PRES(j)=work(work_indx(j),1+ 4*(jj-1)+4)
681 ENDDO
682 ENDDO
683 state_inimap_buf(1)%NUM_CENTROIDS = ncell_tot
684 state_inimap_buf(1)%LENGTH = len_tot
685
686
687 endif! IF(ISPMD == 0 .AND. NSPMD > 1)THEN
688
689 IF(ispmd == 0)THEN
690 IF(ncell_tot == 0 .OR. len_tot == zero)THEN
691 print *, "** ERROR WITH /STATE/INIMAP"
692 print *, " -- SITUATION NOT EXPECTED"
693 print *, " -- 1D DOMAIN IS NOT DETECTED."
694 return
695 ENDIF
696 ENDIF
697
698C-----------------------------------------------
699C O u t p u t F i l e
700C-----------------------------------------------
701
702 IF(ispmd == 0)THEN
703 WRITE(chstat,'(I4.4)')state_inimap_call_number
704 filnam=rootnam(1:rootlen)//'_1D_'//chstat//'.inimap'
705 OPEN(unit=220582,file=filnam(1:len(trim(filnam))),access='SEQUENTIAL',form='FORMATTED',status='UNKNOWN')
706 WRITE(unit=220582,fmt='(A,I10)') '#state file for mappgin with /INIMAP1D, iteration = ',state_inimap_call_number
707 WRITE(unit=220582,fmt='(A,A)') '# ROOTNAME = ',rootnam(1:rootlen)
708 WRITE(unit=220582,fmt='(A,I0)') '# VERSION = ',st_invers
709 WRITE(unit=220582,fmt='(A,F20.13)')'# TIME = ',tt
710 WRITE(unit=220582,fmt='(A,I10)') '# NCYCLE = ',ncycle
711 WRITE(unit=220582,fmt='(A,I10)') '# NCELL = ',ncell_tot
712 !WRITE(UNIT=220582,FMT='(A)')'#//SUBMODEL/1'
713 !WRITE(UNIT=220582,FMT='(A)')'#MAPPING DATA (FUNCTIONS)'
714 !WRITE(UNIT=220582,FMT='(A)')"## off_def off_nod off_ele off_part off_mat off_type off_sub"
715 !WRITE(UNIT=220582,FMT='(A1,7I10)')'#',1000, 0, 0, 0, 0, 0, 0
716 ENDIF
717
718 IF(ispmd == 0)THEN
719 !--- OUTPUT FUNCTION FROM CELL DATA BUFFER ---!
720 nbmat = state_inimap_buf(1)%NSUBMAT
721 shift_c = state_inimap_buf(1)%SHIFT_Cy
722 shift_n = state_inimap_buf(1)%SHIFT_Ny
723 num_centroids = state_inimap_buf(1)%NUM_CENTROIDS
724 !---volume fractions
725 ipos=0 !1:1+21
726 DO isubmat = 1,nbmat
727 WRITE(unit=220582,fmt=2001)ipos+isubmat,isubmat
728 DO k=1, num_centroids
729 WRITE(unit=220582,fmt='(2E20.12)') state_inimap_buf(1)%POS_CENTROIDS(k)
730 . ,state_inimap_buf(1)%SUBMAT(isubmat)%VFRAC(k)
731 ENDDO
732 WRITE(unit=220582,fmt=1500)ipos+isubmat,ipos+isubmat,1.00,1.00,-shift_n,0.00
733 ENDDO
734 !---mass densities
735 ipos=100 !31:31+21
736 DO isubmat = 1,nbmat
737 WRITE(unit=220582,fmt=2002)ipos+isubmat,isubmat
738 DO k=1, num_centroids
739 WRITE(unit=220582,fmt='(2E20.12)') state_inimap_buf(1)%POS_CENTROIDS(k)
740 . ,state_inimap_buf(1)%SUBMAT(isubmat)%RHO(k)
741 ENDDO
742 WRITE(unit=220582,fmt=1500)ipos+isubmat,ipos+isubmat,1.00,1.00,-shift_n,0.00
743 ENDDO
744 !---energy density
745 ipos=200 !31:31+21
746 DO isubmat = 1,nbmat
747 WRITE(unit=220582,fmt=2003)ipos+isubmat,isubmat
748 DO k=1, num_centroids
749 WRITE(unit=220582,fmt='(2E20.12)') state_inimap_buf(1)%POS_CENTROIDS(k)
750 . ,state_inimap_buf(1)%SUBMAT(isubmat)%E(k)
751 ENDDO
752 WRITE(unit=220582,fmt=1500)ipos+isubmat,ipos+isubmat,1.00,1.00,-shift_n,0.00
753 ENDDO
754 !---pressure fraction
755 ipos=300 !91:91+21
756 DO isubmat = 1,nbmat
757 WRITE(unit=220582,fmt=2004)ipos+isubmat,isubmat
758 DO k=1, num_centroids
759 WRITE(unit=220582,fmt='(2E20.12)') state_inimap_buf(1)%POS_CENTROIDS(k)
760 . ,state_inimap_buf(1)%SUBMAT(isubmat)%PRES(k)
761 ENDDO
762 WRITE(unit=220582,fmt=1500)ipos+isubmat,ipos+isubmat,1.00,1.00,-shift_n,0.00
763 ENDDO
764 !--- OUTPUT VELOCITY FUNCTION ---!
765 !
766 WRITE(unit=220582,fmt=3000)
767 DO jj=1,state_inimap_buf(1)%NUM_POINTS
768 WRITE(unit=220582,fmt='(2E20.12)')state_inimap_buf(1)%POS_NODES(jj) , state_inimap_buf(1)%VEL_NODES(jj)
769 ENDDO
770 WRITE(unit=220582,fmt=1500)400,400,1.00,1.00,-shift_n,0.00
771 ENDIF
772
773C-----------------------------------------------
774C D e a l l o c a t e & C l o s e
775C-----------------------------------------------
776 IF(ispmd == 0)THEN
777 !---DEALLOCATE
778 IF(ALLOCATED(map_nodes))DEALLOCATE(map_nodes)
779 IF(ALLOCATED(get_cell_fom_centroid))DEALLOCATE(get_cell_fom_centroid)
780 IF(ALLOCATED(idx))DEALLOCATE(idx)
781 DO jj=1,nspmd
782 nbmat = state_inimap_buf(jj)%NSUBMAT
783 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT))THEN
784 DO i=1,nbmat
785 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%VFRAC))DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%VFRAC)
786 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%RHO))DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%RHO)
787 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%E))DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%E)
788 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT(i)%PRES))DEALLOCATE(state_inimap_buf(jj)%SUBMAT(i)%PRES)
789 ENDDO
790 ENDIF
791 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT ))DEALLOCATE(state_inimap_buf(jj)%SUBMAT)
792 IF(ALLOCATED(state_inimap_buf(jj)%POS_NODES ))DEALLOCATE(state_inimap_buf(jj)%POS_NODES)
793 IF(ALLOCATED(state_inimap_buf(jj)%VEL_NODES ))DEALLOCATE(state_inimap_buf(jj)%VEL_NODES)
794 IF(ALLOCATED(state_inimap_buf(jj)%POS_CENTROIDS))DEALLOCATE(state_inimap_buf(jj)%POS_CENTROIDS)
795 IF(ALLOCATED(state_inimap_buf(jj)%SUBMAT))DEALLOCATE(state_inimap_buf(jj)%SUBMAT)
796 ENDDO
797
798
799 !---OUTPUT FILE : FOOTER & CLOSE
800 WRITE(unit=220582,fmt=1000)
801 !WRITE(UNIT=220582,FMT='(A)')'#//ENDSUB'
802
803 idx1=(/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21/) !vfrac
804 idx2=100+idx1 !rho
805 idx3=300+idx1 !pressure
806 IF(is_stat_inimap_vp)THEN
807 WRITE(unit=220582,fmt='(A)') '#/INIMAP1D/VP/1'
808 ELSE
809 WRITE(unit=220582,fmt='(A)') '#/INIMAP1D/VE/1'
810 ENDIF
811 WRITE(unit=220582,fmt='(A)') '#default input to update from /STATE/INIMAP1D'
812 WRITE(unit=220582,fmt='(A)') '## Type'
813 WRITE(unit=220582,fmt='(A)') '# 1'
814 WRITE(unit=220582,fmt='(A)') '## Node1 Node2'
815 WRITE(unit=220582,fmt='(A)') '# 0 0'
816 WRITE(unit=220582,fmt='(A)') '## Grbric Grquad Grtria'
817 WRITE(unit=220582,fmt='(A)') '# 0 0 0'
818 WRITE(unit=220582,fmt='(A)') '## Fct_v Fscale_v'
819 WRITE(unit=220582,fmt='(A)') '# 400 1.0'
820 DO imat=1,min(21,nbmat)
821 WRITE(unit=220582,fmt='(A)') '## Fct_vf Fct_rho Fscale_rho Fct_p Fscale_p'
822 WRITE(unit=220582,fmt='(A1,I10,2(I10,F20.0))')'#', idx1(imat),idx2(imat),1.0,idx3(imat),1.0
823 ENDDO
824 WRITE(unit=220582,fmt=1000)
825
826 WRITE (iout,500) filnam(1:len(trim(filnam)))
827 WRITE (istdo,500) filnam(1:len(trim(filnam)))
828
829 CLOSE(unit=220582)
830
831 ENDIF
832
833 IF(ALLOCATED(state_inimap_buf))DEALLOCATE(state_inimap_buf)
834
835
836
837
838
839C-----------------------------------------------
840C O u t p u t F o r m a t
841C-----------------------------------------------
842
843 500 FORMAT (4x,' STATE FILE:',1x,a,' WRITTEN')
844
845 1000 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
846
847 1500 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
848 . '/MOVE_FUNCT/',i0,/,
849 . 'move_function__',i0,/,
850 . '# ASCALEx FSCALEy ASHIFTx FSHIFTy',/,
851 . 4(6x,e14.7) )
852
853 2001 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
854 . '/FUNCT/',i0,/,
855 . 'volume fraction submaterial_',i0,/,
856 . '#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
857 2002 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
858 . '/FUNCT/',i0,/,
859 . 'mass density submaterial_',i0,/,
860 . '#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
861 2003 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
862 . '/FUNCT/',i0,/,
863 . 'energy density submaterial_',i0,/,
864 . '#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
865 2004 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
866 . '/FUNCT/',i0,/,
867 . 'pressure submaterial_',i0,/,
868 . '#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
869
870 3000 FORMAT('#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|',/,
871 . '/FUNCT/400',/,
872 . 'velocity_function'/,
873 . '#---1----|----2----|----3----|----4----|----5----|----6----|----7----|----8----|----9----|---10----|')
874C-----------------------------------------------
875 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
message_mod
Definition message_mod.F:1257
state_inimap_mod
Definition state_inimap_mod.F:38
state_inimap_mod::is_stat_inimap_vp
logical is_stat_inimap_vp
Definition state_inimap_mod.F:91
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
recursive subroutine quicksort(a, idx, first, last)
Definition quicksort.F:34
spmd_state_inimap1d_exch_data
subroutine spmd_state_inimap1d_exch_data()
Definition spmd_state_inimap1d_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