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 46 of file stat_inimap1d_file_spmd.F.

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