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

subroutine stat_inimap1d_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_inimap1d_file_spmd.F.

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