OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
w_pon.F File Reference
#include "implicit_f.inc"
#include "tabsiz_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "com_xfem1.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine w_pon (addcne, cne, lcne, numnod_l, nodglob, lcne_l, cep, cel, ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, monvol, ib, geo, igeo, proc, numels_l, numels8_l, numels10_l, numels16_l, numels20_l, numelq_l, numelc_l, numelt_l, numelp_l, numelr_l, numeltg_l, nskyrw_l, nprw, lprw, nskyrbk_l, npby, lpby, dd_rby2, i2nsnt, i2nsn_l, ipari, nir, lcni2_l, niskyi2_l, cepi2, celi2, cni2, addcni2, nbddi2m, nconld_l, ixtg6, numeltg6_l, nnmv_l, nnmvc_l, nskyll_l, nnlink, lllink, nskyrbm_l, dd_rbm2, ibvel, lbvel, nbi18_l, nskyi18_l, len_ia, nconv_l, ibcv, nskyrbe3_l, irbe3, lrbe3, nskyrbmk_l, irbym, lcrbym, front_rm, dd_rbym2, ibcr, nradia_l, addcne_pxfem, cne_pxfem, cel_pxfem, lcnepxfem_l, inod_pxfem, iel_pxfem, numelcpxfem_l, numnodpxfem_l, lloadp, iloadp, llloadp_l, addcne_crkxfem, cne_crkxfem, cel_crkxfem, lcnecrkxfem_l, inod_crkxfem, iel_crkxfem, numelccrkxfe_l, numnodcrkxfe_l, numeltgcrkxfe_l, cep_crkxfem, inod_crk_l, crknodiad, intbuf_tab, numelig3d_l, kxig3d, ixig3d, ibfflux, nfxflux_l, cepcnd, celcnd, addcncnd, cncnd, ns10e_l, icnds10, lcncnd_l, itagnd, igrsurf, igrsurf_proc, local_nebcs, ebcs_tab_loc_2, number_load_cyl, loads, loads_per_proc, glob_therm)

Function/Subroutine Documentation

◆ w_pon()

subroutine w_pon ( integer, dimension(0:numnod+1) addcne,
integer, dimension(*) cne,
integer lcne,
integer numnod_l,
integer, dimension(*) nodglob,
integer lcne_l,
integer, dimension(*) cep,
integer, dimension(*) cel,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) monvol,
integer, dimension(nibcld,*) ib,
geo,
integer, dimension(npropgi,*) igeo,
integer proc,
integer numels_l,
integer numels8_l,
integer numels10_l,
integer numels16_l,
integer numels20_l,
integer numelq_l,
integer numelc_l,
integer numelt_l,
integer numelp_l,
integer numelr_l,
integer numeltg_l,
integer nskyrw_l,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer nskyrbk_l,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(3,nrbykin) dd_rby2,
integer i2nsnt,
integer i2nsn_l,
integer, dimension(npari,*) ipari,
integer nir,
integer lcni2_l,
integer niskyi2_l,
integer, dimension(*) cepi2,
integer, dimension(*) celi2,
integer, dimension(*) cni2,
integer, dimension(0:numnod+1) addcni2,
integer nbddi2m,
integer nconld_l,
integer, dimension(4,*) ixtg6,
integer numeltg6_l,
integer nnmv_l,
integer nnmvc_l,
integer nskyll_l,
integer, dimension(10,*) nnlink,
integer, dimension(*) lllink,
integer nskyrbm_l,
integer, dimension(3,nibvel) dd_rbm2,
integer, dimension(nbvelp,*) ibvel,
integer, dimension(*) lbvel,
integer nbi18_l,
integer nskyi18_l,
integer len_ia,
integer nconv_l,
integer, dimension(glob_therm%niconv,*) ibcv,
integer nskyrbe3_l,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
integer nskyrbmk_l,
integer, dimension(nirbym,*) irbym,
integer, dimension(*) lcrbym,
integer, dimension(nrbym,*) front_rm,
integer, dimension(3,nrbym) dd_rbym2,
integer, dimension(glob_therm%niradia,*) ibcr,
integer nradia_l,
integer, dimension(0:nplyxfe + 1) addcne_pxfem,
integer, dimension(*) cne_pxfem,
integer, dimension(*) cel_pxfem,
integer lcnepxfem_l,
integer, dimension(*) inod_pxfem,
integer, dimension(*) iel_pxfem,
integer numelcpxfem_l,
integer numnodpxfem_l,
integer, dimension(*) lloadp,
integer, dimension(sizloadp,*) iloadp,
integer llloadp_l,
integer, dimension(0:ncrkxfe+1) addcne_crkxfem,
integer, dimension(*) cne_crkxfem,
integer, dimension(*) cel_crkxfem,
integer lcnecrkxfem_l,
integer, dimension(*) inod_crkxfem,
integer, dimension(*) iel_crkxfem,
integer numelccrkxfe_l,
integer numnodcrkxfe_l,
integer numeltgcrkxfe_l,
integer, dimension(*) cep_crkxfem,
integer, dimension(*) inod_crk_l,
integer, dimension(*) crknodiad,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer numelig3d_l,
integer, dimension(nixig3d,*) kxig3d,
integer, dimension(*) ixig3d,
integer, dimension(glob_therm%nitflux,*) ibfflux,
integer nfxflux_l,
integer, dimension(*) cepcnd,
integer, dimension(*) celcnd,
integer, dimension(0:*) addcncnd,
integer, dimension(*) cncnd,
integer ns10e_l,
integer, dimension(3,*) icnds10,
integer lcncnd_l,
integer, dimension(*) itagnd,
type (surf_), dimension(nsurf) igrsurf,
type(surf_), dimension(nsurf,nspmd), intent(in) igrsurf_proc,
integer, intent(in) local_nebcs,
type(t_ebcs_tab), intent(inout) ebcs_tab_loc_2,
integer, intent(in) number_load_cyl,
type(loads_), intent(in) loads,
type(loads_), intent(inout) loads_per_proc,
type (glob_therm_), intent(in) glob_therm )

Definition at line 34 of file w_pon.F.

62C-----------------------------------------------
63C M o d u l e s
64C-----------------------------------------------
65 USE intbufdef_mod
66 USE groupdef_mod
67 USE ebcs_mod
68 USE loads_mod
69 use glob_therm_mod
70 use get_fsky_address_mod , only : get_fsky_address
71 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
72C-----------------------------------------------
73C I m p l i c i t T y p e s
74C-----------------------------------------------
75#include "implicit_f.inc"
76#include "tabsiz_c.inc"
77C-----------------------------------------------
78C C o m m o n B l o c k s
79C-----------------------------------------------
80#include "com01_c.inc"
81#include "com04_c.inc"
82#include "param_c.inc"
83#include "com_xfem1.inc"
84C-----------------------------------------------
85C D u m m y A r g u m e n t s
86C-----------------------------------------------
87 type (glob_therm_) ,intent(in) :: glob_therm
88 INTEGER LCNE, NUMNOD_L, LCNE_L, PROC, I2NSNT, I2NSN_L, NIR,
89 . LCNI2_L, NISKYI2_L, NBDDI2M, NSKYLL_L, NBI18_L,NSKYI18_L,
90 . NUMELS_L ,NUMELS8_L ,NUMELS10_L,NUMELS16_L,NUMELS20_L,
91 . NUMELC_L ,NUMELT_L ,NUMELP_L ,NUMELR_L ,NUMELTG_L,
92 . NUMELQ_L , NSKYRW_L, NSKYRBK_L, NCONLD_L,
93 . NUMELTG6_L, NNMV_L, NNMVC_L, NSKYRBM_L,
94 . ADDCNE(0:NUMNOD+1), CNE(*), NODGLOB(*), CEP(*), CEL(*),
95 . IXS(NIXS,*),IXS10(6,*),IXS20(12,*),IXS16(8,*),
96 . IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),IXP(NIXP,*),
97 . IXR(NIXR,*),IXTG(NIXTG,*),IXTG6(4,*),
98 . IB(NIBCLD,*),MONVOL(*), NPRW(*),
99 . LPRW(*), NPBY(NNPBY,*), LPBY(*),
100 . DD_RBY2(3,NRBYKIN), IPARI(NPARI,*),
101 . CEPI2(*), CELI2(*), CNI2(*), ADDCNI2(0:NUMNOD+1),
102 . NNLINK(10,*), LLLINK(*),
103 . DD_RBM2(3,NIBVEL), IBVEL(NBVELP,*), LBVEL(*),LEN_IA,
104 . NCONV_L ,IBCV(GLOB_THERM%NICONV,*),NSKYRBE3_L,
105 . IRBE3(NRBE3L,*),LRBE3(*),NSKYRBMK_L,
106 . IRBYM(NIRBYM,*) , LCRBYM(*) ,FRONT_RM(NRBYM,*),
107 . DD_RBYM2(3,NRBYM), IBCR(GLOB_THERM%NIRADIA,*), NRADIA_L,
108 . CNE_PXFEM(*),ADDCNE_PXFEM(0:NPLYXFE + 1),CEL_PXFEM(*),
109 . NUMELCPXFEM_L,NUMNODPXFEM_L,INOD_PXFEM(*),IEL_PXFEM(*),
110 . LCNEPXFEM_L,LLOADP(*),ILOADP(SIZLOADP,*),LLLOADP_L,
111 . CNE_CRKXFEM(*),ADDCNE_CRKXFEM(0:NCRKXFE+1),
112 . CEL_CRKXFEM(*),NUMELCCRKXFE_L,NUMNODCRKXFE_L,
113 . INOD_CRKXFEM(*),IEL_CRKXFEM(*),LCNECRKXFEM_L,
114 . NUMELTGCRKXFE_L,CEP_CRKXFEM(*),INOD_CRK_L(*),
115 . CRKNODIAD(*),NUMELIG3D_L,KXIG3D(NIXIG3D,*),IXIG3D(*),
116 . CEPCND(*),CELCND(*),ADDCNCND(0:*),CNCND(*),NS10E_L,ICNDS10(3,*),
117 . LCNCND_L,ITAGND(*),IGEO(NPROPGI,*)
118 INTEGER NFXFLUX_L,IBFFLUX(GLOB_THERM%NITFLUX,*)
119 my_real
120 . geo(npropg,*)
121 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
122 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
123! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
124 TYPE(SURF_), DIMENSION(NSURF,NSPMD), INTENT(IN) :: IGRSURF_PROC
125! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
126! IGRSURF_PROC : SURF_ ; dimension=NSURF*NSPMD
127! local surface property array (=IGRSURF for each proc)
128! %ELTYP --> type of element (shell, triangle...)
129! %ELEM --> element id
130! %NSEG --> total element number
131! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
132 INTEGER, INTENT(IN) :: LOCAL_NEBCS ! number of parallelized ebcs
133 TYPE(T_EBCS_TAB), INTENT(INOUT) :: EBCS_TAB_LOC_2 ! ebcs structure
134 ! load option
135 INTEGER, INTENT(IN) :: NUMBER_LOAD_CYL ! sum of load segment number
136 TYPE(LOADS_),INTENT(IN) :: LOADS ! initial structure of load cyl
137 TYPE(LOADS_), INTENT(INOUT) :: LOADS_PER_PROC ! structure of load cyl for for the current proc P
138C-----------------------------------------------
139C E x t e r n a l F u n c t i o n s
140C-----------------------------------------------
141 INTEGER NLOCAL
142 EXTERNAL nlocal
143C-----------------------------------------------
144C L o c a l V a r i a b l e s
145C-----------------------------------------------
146 INTEGER N, I, PROC_L, CC, CC_L, N1, N2, N3, N4,
147 . K, K0, K1, K6, NV, KN, JJ, INACTI,NG,NUMG0,
148 . IS,NN,IAD,J,ITY,CLOAD,NUML,NUMG, II, MAIN,J_L,IPVENT,
149 . NSL, NSL_L, KK, P,K_ L, MSR, PMAIN, NTY, NRTS,NL_L,N0,
150 . NRTM, NSN, NMN, K10, K11, K12, K13, K14, L, NSN_L, OFFTG,
151 . OFFC,ITYP,NVENT,IV,IADHOL,KIBHOL,KIBJET,K2,NNC,KAD,NAV,J0,
152 . NRTM_FE, NRTS_FE, N_L
153 INTEGER :: IDEBRBK(NSPMD)
154 INTEGER :: PROCNE_PXFEM(LCNEPXFEM_L)
155 INTEGER :: IADC_PXFEM(4,NUMELCPXFEM_L)
156 INTEGER :: ADDCNEPXFEM_L(NUMNODPXFEM_L+1)
157 INTEGER :: PROCNE_CRKXFEM(LCNECRKXFEM_L)
158 INTEGER :: ADDCNECRKXFEM_L(NUMNODCRKXFE_L+1)
159 INTEGER :: IADC_CRKXFEM(4,NUMELCCRKXFE_L)
160 INTEGER :: CNE_CRKXFEM_L(LCNECRKXFEM_L)
161 INTEGER :: IADTG_CRKXFEM(3,NUMELTGCRKXFE_L)
162 INTEGER :: CEL_CRKXFEM_L(LCNECRKXFEM_L)
163 INTEGER :: CRKNODIAD_L(LCNECRKXFEM_L)
164
165 INTEGER, ALLOCATABLE :: PROCNE(:)
166 INTEGER, ALLOCATABLE :: ITAGIB(:)
167 INTEGER, ALLOCATABLE :: IADMV(:,:)
168 INTEGER, ALLOCATABLE :: IADMV2(:)
169 INTEGER, ALLOCATABLE :: IADMV3(:)
170 INTEGER, ALLOCATABLE :: IADWAL(:)
171 INTEGER, ALLOCATABLE :: IADRBK(:)
172 INTEGER, ALLOCATABLE :: IADI2(:,:)
173 INTEGER, ALLOCATABLE :: I2TMP(:,:)
174 INTEGER, ALLOCATABLE :: IADLL(:)
175 INTEGER, ALLOCATABLE :: PROCNI2(:)
176 INTEGER, ALLOCATABLE :: IADRBM(:)
177 INTEGER, ALLOCATABLE :: IADI18(:)
178 INTEGER, ALLOCATABLE :: IADIBCV(:,:)
179 INTEGER, ALLOCATABLE :: IADIBFX(:,:)
180 INTEGER, ALLOCATABLE :: IADRBMK(:)
181 INTEGER, ALLOCATABLE :: IADIBCR(:,:)
182 INTEGER, ALLOCATABLE :: ITAGLOADP(:)
183 INTEGER, ALLOCATABLE :: IADLOAD(:,:)
184 INTEGER, ALLOCATABLE :: ICNDTMP(:,:)
185 INTEGER, ALLOCATABLE :: PROCNCND(:)
186 INTEGER, ALLOCATABLE :: IADCND(:,:)
187
188
189 INTEGER IUN,EMPL,COORD,SHFT,TESTVAL,KD(50),KFI
190 INTEGER, DIMENSION(:), ALLOCATABLE :: SOLTAG,SOL10TAG,
191 . SOL20TAG,SOL16TAG,QUADTAG,SHTAG,TTAG,PTAG,RTAG,TGTAG,TG6TAG,
192 . IBTAG,IBCVTAG,IBCRTAG,IBFXTAG,ILTAG,TAGIG3D
193 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAGC, ITAGTG,ADDCNE_L,ADDCNI2_L,
194 . ADDCNCND_L
195 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IADS,IADS10,
196 . IADS16,IADS20,IADQ,IADC,IADT,
197 . IADP,IADR,IADTG,IADIB,
198 . IADTG1,IADIG3D
199 TYPE(ebcs_parith_on), DIMENSION(:), ALLOCATABLE :: EBCS_PARITHON_L ! adress for the fsky array for parith/on
200 LOGICAL, DIMENSION(:), ALLOCATABLE :: EBCS_TAG ! boolean : true if the element belongs to an ebcs
201 INTEGER :: LOCAL_NODE_ID,ELEM_ID,NUMG_SAVE
202
203 ! loads option
204 INTEGER :: GLOBAL_SEGMENT_ID ! global segment id
205 INTEGER :: LOCAL_PROC_ID ! processor id where the segment is defined
206 INTEGER :: LOCAL_SEGMENT_ID ! local segment id (local to the proc LOCAL_PROC_ID)
207 INTEGER :: GLOBAL_LOAD_ID,LOCAL_LOAD_ID ! load id (global and local to proc LOCAL_PROC_ID)
208
209 logical :: bool
210 integer, parameter :: nixs10 = 6
211 integer, parameter :: nixs20 = 12
212 integer, parameter :: nixs16 = 8
213 ! offset
214 integer :: solid_offset,tetra10_offset,hexa20_offset
215 integer :: solid16_offset,quad_offset,shell_offset
216 integer :: truss_offset,beam_offset,spring_offset
217 integer :: triangle_offset,low_triangle6_offset,bc_offset
218 integer :: thermal_conv_offset,thermal_rad_offset,thermal_flux_offset
219 integer :: load_offset,ig3d_offset,load_cyl_offset,last_offset
220 ! first dimension of address array
221 integer, parameter :: s_iads = 8
222 integer, parameter :: s_iads10 = 6
223 integer, parameter :: s_iads16 = 8
224 integer, parameter :: s_iads20 = 12
225 integer, parameter :: s_iadq = 4
226 integer, parameter :: s_iadc = 4
227 integer, parameter :: s_iadt = 2
228 integer, parameter :: s_iadp = 2
229 integer, parameter :: s_iadr = 3
230 integer, parameter :: s_iadtg = 3
231 integer, parameter :: s_iadib = 4
232 integer, parameter :: s_iadtg1 = 3
233 integer, parameter :: s_iadig3d = 100
234 integer, parameter :: s_iadload = 4
235 integer, parameter :: s_iadibcv = 4
236 integer, parameter :: s_iadibfx = 4
237 integer, parameter :: s_iadibcr = 4
238
239
240 logical, parameter :: ref = .false.
241C-----------------------------------------------
242
243 ALLOCATE(procne(lcne_l))
244 ALLOCATE(itagib(nconld))
245 ALLOCATE(iadmv(4, nnmv_l))
246 ALLOCATE(iadmv2(nnmv_l))
247 ALLOCATE(iadmv3(nnmvc_l))
248 ALLOCATE(iadwal(nskyrw_l))
249 ALLOCATE(iadrbk(nskyrbk_l))
250 ALLOCATE(iadi2(nir, i2nsn_l))
251 ALLOCATE(i2tmp(nir, i2nsn_l))
252 ALLOCATE(iadll(nskyll_l))
253 ALLOCATE(procni2(lcni2_l))
254 ALLOCATE(iadrbm(nskyrbm_l))
255 ALLOCATE(iadi18(nskyi18_l))
256 ALLOCATE(iadibcv(4, nconv_l))
257 ALLOCATE(iadibfx(4, nfxflux_l))
258 ALLOCATE(iadrbmk(nskyrbmk_l))
259 ALLOCATE(iadibcr(4, nradia_l))
260 ALLOCATE(itagloadp(slloadp))
261 ALLOCATE(iadload(4, llloadp_l))
262 ALLOCATE(icndtmp(3, ns10e_l))
263 ALLOCATE(procncnd(lcncnd_l))
264 ALLOCATE(iadcnd(2, ns10e_l))
265
266 iun = 1
267 ALLOCATE(soltag(numels))
268 soltag(1:numels)=0
269
270 ALLOCATE(sol10tag(numels10))
271 sol10tag(1:numels10)=0
272
273 ALLOCATE(sol20tag(numels20))
274 sol20tag(1:numels20)=0
275
276 ALLOCATE(sol16tag(numels16))
277 sol16tag(1:numels16)=0
278
279 ALLOCATE(quadtag(numelq))
280 quadtag(1:numelq)=0
281
282 ALLOCATE(shtag(numelc))
283 shtag(1:numelc)=0
284
285 ALLOCATE(ttag(numelt))
286 ttag(1:numelt)=0
287
288 ALLOCATE(ptag(numelp))
289 ptag(1:numelp)=0
290
291 ALLOCATE(rtag(numelr))
292 rtag(1:numelr)=0
293
294 ALLOCATE(tgtag(numeltg))
295 tgtag(1:numeltg)=0
296
297 ALLOCATE(tg6tag(numeltg6))
298 tg6tag(1:numeltg6)=0
299
300 ALLOCATE(ibtag(nconld))
301 ibtag(1:nconld)=0
302
303 ALLOCATE(ibcvtag(glob_therm%NUMCONV))
304 ibcvtag(1:glob_therm%NUMCONV)=0
305
306 ALLOCATE(ibcrtag(glob_therm%NUMRADIA))
307 ibcrtag(1:glob_therm%NUMRADIA)=0
308
309 ALLOCATE(ibfxtag(glob_therm%NFXFLUX))
310 ibfxtag(1:glob_therm%NFXFLUX)=0
311
312 ALLOCATE(iltag(slloadp/4))
313 iltag(1:slloadp/4)=0
314
315 ALLOCATE(tagig3d(numelig3d))
316 tagig3d(1:numelig3d)=0
317! ------------------------------
318! allocate 1d arrays
319 ALLOCATE( itagc(numelc),itagtg(numeltg) )
320 ALLOCATE( addcne_l(numnod_l+1),addcni2_l(numnod_l+1))
321 addcne_l(1:numnod_l + 1) = 0
322 ALLOCATE( addcncnd_l(numnod_l+1))
323! IAD 2D arrays
324 ALLOCATE( iads(8,numels_l),iads10(6,numels10_l) )
325 ALLOCATE( iads16(8,numels16_l),iads20(12,numels20_l) )
326 ALLOCATE( iadq(4,numelq_l),iadc(4,numelc_l) )
327 ALLOCATE( iadt(2,numelt_l),iadp(2,numelp_l) )
328 ALLOCATE( iadr(3,numelr_l),iadtg(3,numeltg_l) )
329 iadr(1:3,1:numelr_l) = 0
330 iadtg(1:3,1:numeltg_l) = 0
331 ALLOCATE(iadib(4,nconld_l) )
332 if(nconld_l >0) iadib(1:4,1:nconld_l) = -huge(i)
333 ALLOCATE( iadtg1(3,numeltg6_l),iadig3d(100,numelig3d_l) )
334! ------------------------------
335
336C-----------------------------------------------
337C
338C PLOADS PRE-TRAINING
339C
340 cload = 0
341 DO i = 1, nconld
342 IF(ib(4,i)==-1)THEN
343 itagib(i) = 1
344 cload = 1
345 ELSE
346 itagib(i) = 0
347 ENDIF
348 ENDDO
349C Pre-treatment LOADS
350C
351 k=0
352 DO i = 1, nloadp
353 DO j=1,iloadp(1,i)/4
354 k = k+1
355 itagloadp(k) = 0
356 ENDDO
357 ENDDO
358C
359C PRE-TRAINING MV
360C
361 IF (nvolu>0) THEN
362 DO i = 1, numelc
363 itagc(i) = 0
364 ENDDO
365 DO i = 1, numeltg
366 itagtg(i) = 0
367 ENDDO
368C
369 k0 = 0
370 k1 = 1
371 k2 = 1 + nimv*nvolu
372 kibjet = k2 + licbag
373 kibhol = kibjet + libagjet
374 k6 = 0
375 offc = numels+numelq
376 offtg =numels+numelq+ numelc+numelt+numelp+numelr
377 j_l = 0
378 DO n = 1, nvolu
379 ityp = monvol(k1+1)
380 is = monvol(k1+3)
381 nav = monvol(k1+2)
382 nvent = monvol(k1+10)
383 nn = igrsurf(is)%NSEG
384 iadhol= kibhol+monvol(k1+11)
385 j0 = j_l
386 DO j = 1, nn
387 ity = igrsurf(is)%ELTYP(j)
388 i = igrsurf(is)%ELEM(j)
389 IF (ity==3) THEN
390 itagc(i) = 1
391 IF(cep(i+offc)==proc-1) THEN
392 j_l = j_l + 1
393 iadmv2(j_l) = j
394C save local number J corresponding to I
395 itagc(i) = j_l - j0
396 END IF
397 ELSEIF (ity==7) THEN
398 itagtg(i) = 1
399 IF(cep(i+offtg)==proc-1) THEN
400 j_l = j_l + 1
401 iadmv2(j_l) = j
402C save local number J corresponding to I
403 itagtg(i) = j_l - j0
404 END IF
405 ELSE
406 ENDIF
407 ENDDO
408C
409C Hole wind treatment and communicating volume
410C
411 IF(ityp==3.OR.ityp==4.OR.ityp==5.OR.ityp==7.OR.ityp==9) THEN
412 DO iv = 1, nvent
413 ipvent = monvol(iadhol+nibhol*(iv-1)+2-1)
414 IF(ipvent/=0) THEN
415 nnc=igrsurf(ipvent)%NSEG
416 DO j = 1, nnc
417 ity = igrsurf(ipvent)%ELTYP(j)
418 i = igrsurf(ipvent)%ELEM(j)
419 IF (ity==3) THEN
420 IF(cep(i+offc)==proc-1) THEN
421 k0 = k0 + 1
422C restitution of the local no (surface) corresponding to i
423 iadmv3(k0) = itagc(i)
424 END IF
425 ELSEIF (ity==7) THEN
426 IF(cep(i+offtg)==proc-1) THEN
427 k0 = k0 + 1
428C restitution of the local no (surface) corresponding to i
429 iadmv3(k0) = itagtg(i)
430 END IF
431 END IF
432 END DO
433 END IF
434 END DO
435 END IF
436 IF(ityp==4.OR.ityp==5.OR.ityp==7.OR.ityp==9)THEN
437 DO iv = 1, nav
438 ipvent = monvol(k2+nicbag*(iv-1)+2-1)
439 IF(ipvent/=0) THEN
440 nnc=igrsurf(ipvent)%NSEG
441 DO j = 1, nnc
442 ity = igrsurf(ipvent)%ELTYP(j)
443 i = igrsurf(ipvent)%ELEM(j)
444 IF (ity==3) THEN
445 IF(cep(i+offc)==proc-1) THEN
446 k0 = k0 + 1
447C restitution of the local no (surface) corresponding to i
448 iadmv3(k0) = itagc(i)
449 END IF
450 ELSEIF (ity==7) THEN
451 IF(cep(i+offtg)==proc-1) THEN
452 k0 = k0 + 1
453C restitution of the local no (surface) corresponding to i
454 iadmv3(k0) = itagtg(i)
455 END IF
456 END IF
457 END DO
458 END IF
459 END DO
460 END IF
461 k1 = k1 + nimv
462 k2 = k2 + nicbag * nav
463 k6 = k6 + nn
464 ENDDO
465 ENDIF
466C
467 DO k = 1, 4
468 DO i = 1, nnmv_l
469 iadmv(k,i) = 0
470 END DO
471 END DO
472C
473C Elts penta
474C
475 IF(numeltg6_l>0)THEN
476 DO i = 1, numeltg6_l
477 DO k = 1,3
478 iadtg1(k,i)=0
479 ENDDO
480 ENDDO
481 ENDIF
482
483 ! --------------------------
484 ! tag the element belonging to an ebcs
485 ALLOCATE( ebcs_tag(numels+numelq+numeltg) )
486 ebcs_tag(1:numels+numelq+numeltg) = .false.
487 ALLOCATE(ebcs_parithon_l(local_nebcs))
488 IF(local_nebcs>0) THEN
489 ! ---------------------
490 ! loop over the /EBCS
491 DO i=1,local_nebcs
492 ! allocation of adress array
493 ALLOCATE( ebcs_parithon_l(i)%ELEM_ADRESS(4,ebcs_tab_loc_2%tab(i)%poly%nb_elem) )
494 ebcs_parithon_l(i)%ELEM_ADRESS(1:4,1:ebcs_tab_loc_2%tab(i)%poly%nb_elem) = 0
495 ! check if a surface is associated to the ebcs
496 IF(ebcs_tab_loc_2%tab(i)%poly%surf_id>0) THEN
497 ! ---------------------
498 ! loop over the element of the surface to tag the element
499 DO j=1,ebcs_tab_loc_2%tab(i)%poly%nb_elem
500 elem_id = ebcs_tab_loc_2%tab(i)%poly%global_ielem(j)
501 IF(n2d/=0) THEN
502 IF(elem_id>numels+numelq) THEN
503 elem_id = elem_id - (numelc+numelt+numelp+numelr)
504 ENDIF
505 ENDIF
506 ebcs_tag(elem_id) = .true.
507 ENDDO
508 ! ---------------------
509 ENDIF
510 ENDDO
511 ! ---------------------
512 ENDIF
513 ! --------------------------
514C-----------------------------------------------
515C ADDCNE_L and IADS
516C-----------------------------------------------
517C
518C-----------------------------------------------
519C The algorithm has been modified to avoid using the element
520C arrays as markers.
521C INTEGER arrays for every elements types has been introduced
522C Each entry is used as 31 bit array.
523C The access is done with fortran intrinsics ISHIFT
524C Verification with fortran Intrinsics IAND.
525C-----------------------------------------------
526C
527 ! --------------------
528 ! define offsets
529 solid_offset = 0
530 tetra10_offset = numels8
531 hexa20_offset = tetra10_offset + numels10
532 solid16_offset = hexa20_offset + numels20
533 quad_offset = solid_offset + numels
534 shell_offset = quad_offset + numelq
535 truss_offset = shell_offset + numelc
536 beam_offset = truss_offset + numelt
537 spring_offset = beam_offset + numelp
538 triangle_offset = spring_offset + numelr
539 low_triangle6_offset = triangle_offset + numeltg - numeltg6
540 bc_offset = triangle_offset + numeltg + numelx ! X element are no longer supported
541 thermal_conv_offset = bc_offset + nconld
542 thermal_rad_offset = thermal_conv_offset + glob_therm%numconv
543 thermal_flux_offset = thermal_rad_offset + glob_therm%numradia
544 load_offset = thermal_flux_offset + glob_therm%nfxflux
545 ig3d_offset = load_offset + slloadp/4
546 load_cyl_offset = ig3d_offset + numelig3d
547 last_offset = load_cyl_offset + number_load_cyl
548
549 ! --------------------
550 addcne_l(1) = 1
551 cc_l = 0
552 DO i = 1, numnod_l ! loop over the local nodes
553 n = nodglob(i) ! get the global node id
554 n1 = addcne(n) ! get the starting position in CNE array
555 n2 = addcne(n+1) ! get the end position in CNE array
556 addcne_l(i+1) = addcne_l(i) + n2-n1 ! fill the ADDCNE_L array
557 DO cc = n1, n2-1 ! loop over the contributions of the local node I (or global node N)
558 numg = cne(cc) ! get the global element id
559 numg_save = cne(cc) ! save for ebcs
560 numl = cel(numg) ! get the local element id
561 proc_l = cep(numg)+1 ! get the processor owning the element
562 cc_l = cc_l + 1 ! local counter, address to point to the good place in FSKY array
563 procne(cc_l) = proc_l
564 ! --------------------
565 ! check if the element is on the current proc
566 IF (proc==proc_l) THEN
567 ! -------------
568 ! Solid element
569 IF (numg>solid_offset.and.numg<=quad_offset) THEN
570 numg = numg - solid_offset ! get the solid element id (1:numels)
571 ! -------------
572 ! general case : 8 contributions
573 call get_fsky_address(bool,nixs,1,numg,numl,cc_l,8,n,numels,numels_l,soltag,ixs,s_iads,iads)
574 if(bool) goto 100
575
576 ! -------------
577 ! Specific case : tetra10, add 6 other contributions
578 if(numels10>0.and.numg>tetra10_offset.and.numg<=hexa20_offset) then
579 numg=numg-numels8 ! get the tetra10 element id (1:numels10)
580 call get_fsky_address(bool,nixs10,0,numg,numl-numels8_l,cc_l,6,n,numels10,numels10_l,
581 . sol10tag,ixs10,s_iads10,iads10)
582 if(bool) goto 100
583 ! -------------
584 ! Special case : hexa20, add 12 other contributions
585 elseif(numels20>0.and.numg>hexa20_offset.and.numg<=solid16_offset) then
586 numg=numg-numels8-numels10 ! get the hexa20 element id (1:numels20)
587 call get_fsky_address(bool,nixs20,0,numg,numl-numels8_l-numels10_l,cc_l,12,n,numels20,numels20_l,
588 . sol20tag,ixs20,s_iads20,iads20)
589 if(bool) goto 100
590 ! -------------
591 ! Special case : hexa16, add 8 other contributions
592 elseif(numels16>0.and.numg>solid16_offset) then
593 numg=numg-numels8-numels10-numels20 ! get the solid16 element id (1:numels16)
594 call get_fsky_address(bool,nixs16,0,numg,numl-numels8_l-numels10_l-numels20_l,cc_l,8,n,numels16,numels16_l,
595 . sol16tag,ixs16,s_iads16,iads16)
596 if(bool) goto 100
597 endif
598 ! -------------
599
600 ! -------------
601 ! element belongs to an ebcs
602 IF(ebcs_tag(numg_save)) THEN
603 DO ii=1,local_nebcs
604 ! check if a surface is associated to the ebcs
605 IF(ebcs_tab_loc_2%tab(ii)%poly%surf_id>0) THEN
606 ! -------------
607 ! loop over the element of the surface
608 DO j=1,ebcs_tab_loc_2%tab(ii)%poly%nb_elem
609 elem_id = ebcs_tab_loc_2%tab(ii)%poly%global_ielem(j) ! global element id
610 ! -------------
611 ! find the location of the node :
612 ! 4 nodes for a solid
613 ! 1 2
614 ! o-----o
615 ! | |
616 ! o-----o
617 ! 4 3
618 IF(elem_id==numg_save) THEN
619 DO k=1,4
620 local_node_id = ebcs_tab_loc_2%tab(ii)%poly%elem_list(k,j)
621 local_node_id = ebcs_tab_loc_2%tab(ii)%poly%node_list(local_node_id)
622 IF(n==nodglob(local_node_id)) THEN
623 IF(ebcs_parithon_l(ii)%ELEM_ADRESS(k,j)==0) THEN
624 ebcs_parithon_l(ii)%ELEM_ADRESS(k,j) = cc_l
625 GOTO 100
626 ENDIF
627 ENDIF
628 ENDDO
629 ENDIF
630 ! -------------
631 ENDDO
632 ! -------------
633 ENDIF
634 ENDDO
635 ENDIF
636 ! -------------
637 ! --------------------
638 ! quad element
639 ELSEIF(numg>quad_offset.and.numg<=shell_offset)THEN
640 ! -------------
641 call get_fsky_address(bool,nixq,1,numg,numl,cc_l,4,n,numelq,numelq_l,quadtag,ixq,s_iadq,iadq)
642 if(bool) goto 100
643
644 ! -------------
645 ! element belongs to an ebcs
646 IF(ebcs_tag(numg_save)) THEN
647 DO ii=1,local_nebcs
648 ! check if a surface is associated to the ebcs
649 IF(ebcs_tab_loc_2%tab(ii)%poly%surf_id>0) THEN
650 ! -------------
651 ! loop over the element of the surface
652 DO j=1,ebcs_tab_loc_2%tab(ii)%poly%nb_elem
653 elem_id = ebcs_tab_loc_2%tab(ii)%poly%global_ielem(j) ! global element id
654 ! -------------
655 ! find the location of the node for a quad :
656 ! only 2 nodes for the surface (2D case)
657 ! 1 2
658 ! o-----o
659 ! | |
660 ! o-----o
661 ! 4 3
662 IF(elem_id==numg_save) THEN
663 DO k=1,2
664 local_node_id = ebcs_tab_loc_2%tab(ii)%poly%elem_list(k,j)
665 local_node_id = ebcs_tab_loc_2%tab(ii)%poly%node_list(local_node_id)
666 IF(n==nodglob(local_node_id)) THEN
667 IF(ebcs_parithon_l(ii)%ELEM_ADRESS(k,j)==0) THEN
668 ebcs_parithon_l(ii)%ELEM_ADRESS(k,j) = cc_l
669 GOTO 100
670 ENDIF
671 ENDIF
672 ENDDO
673 ENDIF
674 ! -------------
675 ENDDO
676 ! -------------
677 ENDIF
678 ENDDO
679 ENDIF
680 ! -------------
681 ! --------------------
682 ! shell element
683 ELSEIF(numg>shell_offset.and.numg<=truss_offset) THEN
684 ! -------------
685 numg = numg - shell_offset ! get the shell element id (1:numelc)
686 call get_fsky_address(bool,nixc,1,numg,numl,cc_l,4,n,numelc,numelc_l,shtag,ixc,s_iadc,iadc)
687 if(bool) goto 100
688
689 ! -------------
690 ! Shell element belonging to a monitor volume
691 IF (nvolu>0) THEN
692 IF(itagc(numg)>0) THEN
693 k1 = 1
694 k6 = 0
695 DO nv = 1, nvolu
696 is = monvol(k1+3)
697 nn = igrsurf_proc(is,proc)%NSEG
698 jj = 0
699 DO j = 1, nn
700 ity = igrsurf_proc(is,proc)%ELTYP(j)
701 ii = igrsurf_proc(is,proc)%ELEM(j)
702 IF(ity==3) THEN
703 IF(cep(offc+ii)==proc-1) THEN
704 jj = jj+1
705 IF (ii==numg) THEN
706 DO k = 2,5
707 IF(ixc(k,ii)==n.AND.iadmv(k-1,k6+jj)==0) THEN
708 iadmv(k-1,k6+jj) = cc_l
709 GOTO 100
710 END IF
711 END DO
712 END IF
713 END IF
714 ELSEIF(ity==7)THEN
715 IF(cep(offtg+ii)==proc-1) THEN
716 jj = jj+1
717 END IF
718 END IF
719 END DO
720 k1 = k1 + nimv
721 k6 = k6 + jj
722 ENDDO
723 ENDIF
724 ENDIF
725 ! -------------
726 ! --------------------
727 ! truss element
728 ELSEIF(numg>truss_offset.and.numg<=beam_offset) THEN
729 numg = numg - truss_offset ! get the truss element id (1:numelt)
730 call get_fsky_address(bool,nixt,1,numg,numl,cc_l,2,n,numelt,numelt_l,ttag,ixt,s_iadt,iadt)
731 if(bool) goto 100
732
733 ! --------------------
734 ! beam element
735 ELSEIF(numg>beam_offset.and.numg<=spring_offset) THEN
736 numg = numg - beam_offset ! get the beam element id (1:numelp)
737 call get_fsky_address(bool,nixp,1,numg,numl,cc_l,2,n,numelp,numelp_l,ptag,ixp,s_iadp,iadp)
738 if(bool) goto 100
739
740 ! --------------------
741 ! spring element
742 ELSEIF(numg>spring_offset.and.numg<=triangle_offset) THEN
743 numg = numg - spring_offset ! get the spring element id (1:numelr)
744 call get_fsky_address(bool,nixr,1,numg,numl,cc_l,2,n,numelr,numelr_l,rtag,ixr,s_iadr,iadr)
745 if(bool) goto 100
746
747 ! special case : spring 1D element (beam) in 3D
748 IF(igeo(11,ixr(1,numg))==12) THEN
749 shft = ishft(iun,3)
750 testval =iand(rtag(numg),shft)
751 IF (ixr(4,numg)==n.AND.testval==0) THEN
752 iadr(3,numl) = cc_l
753 rtag(numg)=rtag(numg)+shft
754 GOTO 100
755 ENDIF
756 ENDIF
757 ! --------------------
758 ! shell 3n (triangle) element
759 ELSEIF(numg>triangle_offset.and.numg<=bc_offset) THEN
760 ! -------------
761 ! general case : triangle
762 numg = numg - triangle_offset ! get the triangle element id (1:numeltg)
763 call get_fsky_address(bool,nixtg,1,numg,numl,cc_l,3,n,numeltg,numeltg_l,tgtag,ixtg,s_iadtg,iadtg)
764 if(bool) goto 100
765 ! -------------
766
767 ! -------------
768 ! sub-case : triangle6
769 if(numeltg6>0.and.numg>low_triangle6_offset.and.numg<=bc_offset) then
770 numg = numg - numeltg + numeltg6 ! get the triangle6 element id (1:numeltg6)
771 call get_fsky_address(bool,nixtg,0,numg,numl,cc_l,3,n,numeltg,numeltg_l,tg6tag,ixtg6,s_iadtg1,iadtg1)
772 if(bool) goto 100
773 endif
774 ! -------------
775
776 ! -------------
777 ! monitor volume : triangle
778 IF (nvolu>0) THEN
779 IF(itagtg(numg)>0) THEN
780 k1 = 1
781 k6 = 0
782 DO nv = 1, nvolu
783 is = monvol(k1+3)
784 nn = igrsurf_proc(is,proc)%NSEG
785 jj = 0
786 DO j = 1, nn
787 ity = igrsurf_proc(is,proc)%ELTYP(j)
788 ii = igrsurf_proc(is,proc)%ELEM(j)
789 IF(ity==7) THEN
790 IF(cep(offtg+ii)==proc-1) THEN
791 jj = jj+1
792 IF (ii==numg) THEN
793 DO k = 2,4
794 IF(ixtg(k,ii)==n.AND.iadmv(k-1,k6+jj)==0) THEN
795 iadmv(k-1,k6+jj) = cc_l
796 GOTO 100
797 END IF
798 END DO
799 END IF
800 END IF
801 ELSEIF(ity==3) THEN
802 IF(cep(offc+ii)==proc-1) THEN
803 jj = jj+1
804 END IF
805 END IF
806 END DO
807 k1 = k1 + nimv
808 k6 = k6 + jj
809 ENDDO
810 ENDIF
811 ENDIF
812 ! -------------
813
814 ! -------------
815 ! element belongs to an ebcs
816 IF(ebcs_tag(numg_save-(numelc+numelt+numelp+numelr))) THEN
817 DO ii=1,local_nebcs
818 ! check if a surface is associated to the ebcs
819 IF(ebcs_tab_loc_2%tab(ii)%poly%surf_id>0) THEN
820 ! -------------
821 ! loop over the element of the surface
822 DO j=1,ebcs_tab_loc_2%tab(ii)%poly%nb_elem
823 elem_id = ebcs_tab_loc_2%tab(ii)%poly%global_ielem(j) ! global element id
824 ! -------------
825 ! find the location of the node for a triangle :
826 ! only 2 nodes for the surface (2D case)
827 ! 1
828 ! o
829 ! / \
830 ! / \
831 ! o-----o
832 ! 3 2
833 IF(elem_id==numg_save) THEN
834 DO k=1,2
835 local_node_id = ebcs_tab_loc_2%tab(ii)%poly%elem_list(k,j)
836 IF(local_node_id>0) THEN
837 IF(n==nodglob(local_node_id)) THEN
838 IF(ebcs_parithon_l(ii)%ELEM_ADRESS(k,j)==0) THEN
839 ebcs_parithon_l(ii)%ELEM_ADRESS(k,j) = cc_l
840 GOTO 100
841 ENDIF
842 ENDIF
843 ENDIF
844 ENDDO
845 ENDIF
846 ! -------------
847 ENDDO
848 ! -------------
849 ENDIF
850 ENDDO
851 ENDIF
852 ! -------------
853 ! --------------------
854 ! Boundary conditions
855 ELSEIF(numg>bc_offset.and.numg<=thermal_conv_offset) THEN
856 numg = numg - bc_offset ! get the pseudo element id for this boundary condition (1:nconld)
857 IF(itagib(numg)==0.AND.n2d==0)THEN
858 kn = 4
859 ELSEIF(itagib(numg)==0.AND.n2d/=0)THEN
860 kn = 2
861 ELSE
862 kn = 1
863 ENDIF
864 call get_fsky_address(bool,nibcld,0,numg,numl,cc_l,kn,n,nconld,nconld_l,ibtag,ib,s_iadib,iadib)
865 if(bool) goto 100
866 ! --------------------
867 ! Boundary conditions : convection
868 ELSEIF(numg>thermal_conv_offset.and.numg<=thermal_rad_offset) THEN
869 numg = numg - thermal_conv_offset ! get the pseudo element id for this boundary condition (1:glob_therm%numconv)
870 IF(n2d==0)THEN
871 kn = 4
872 ELSEIF(n2d/=0)THEN
873 kn = 2
874 ELSE
875 kn = 1
876 ENDIF
877 call get_fsky_address(bool,glob_therm%niconv,0,numg,numl,cc_l,kn,n,glob_therm%numconv,nconv_l,
878 . ibcvtag,ibcv,s_iadibcv,iadibcv)
879 if(bool) goto 100
880 ! --------------------
881 ! Boundary conditions : radiation
882 ELSEIF(numg>thermal_rad_offset.and.numg<=thermal_flux_offset) THEN
883 numg = numg - thermal_rad_offset ! get the pseudo element id for this boundary condition (1:glob_therm%numradia)
884 IF(n2d==0)THEN
885 kn = 4
886 ELSEIF(n2d/=0)THEN
887 kn = 2
888 ELSE
889 kn = 1
890 ENDIF
891 call get_fsky_address(bool,glob_therm%niradia,0,numg,numl,cc_l,kn,n,glob_therm%numradia,nradia_l,
892 . ibcrtag,ibcr,s_iadibcr,iadibcr)
893 if(bool) goto 100
894 ! --------------------
895 ! Boundary conditions : flux
896 ELSEIF(numg>thermal_flux_offset.and.numg<=load_offset) THEN
897 numg = numg - thermal_flux_offset ! get the pseudo element id for this boundary condition (1:glob_therm%nfxflux)
898 IF(n2d==0)THEN
899 kn = 4
900 ELSEIF(n2d/=0)THEN
901 kn = 2
902 ELSE
903 kn = 1
904 ENDIF
905 call get_fsky_address(bool,glob_therm%nitflux,0,numg,numl,cc_l,kn,n,glob_therm%nfxflux,nfxflux_l,
906 . ibfxtag,ibfflux,s_iadibfx,iadibfx)
907 if(bool) goto 100
908 ! --------------------
909 ! Boundary conditions : loads
910 ELSEIF(numg>load_offset.and.numg<=ig3d_offset) THEN
911 numg = numg - load_offset ! get the pseudo element id for this boundary condition (1:slloadp/4)
912 IF(itagloadp(numg)==0.AND.n2d==0)THEN
913 kn = 4
914 ELSEIF(itagloadp(numg)==0.AND.n2d/=0)THEN
915 kn = 2
916 ELSE
917 kn = 1
918 ENDIF
919 call get_fsky_address(bool,4,0,numg,numl,cc_l,kn,n,slloadp/4,llloadp_l,iltag,lloadp,s_iadload,iadload)
920 if(bool) goto 100
921 ! --------------------
922 ! IG3D elements
923 ELSEIF(numg>ig3d_offset.and.numg<=load_cyl_offset) THEN
924 numg = numg - ig3d_offset ! get the pseudo element id for this boundary condition (1:numelig3d)
925 DO k = 1,20
926 shft = ishft(iun,k-1)
927 testval = iand(tagig3d(numg),shft)
928 IF (ixig3d(kxig3d(4,numg)+k-1)==n.AND.testval==0) THEN
929 iadig3d(k,numl) = cc_l
930 tagig3d(numg)=tagig3d(numg)+shft
931 GOTO 100
932 ENDIF
933 ENDDO
934 ! --------------------
935 ! Boundary conditions : pcyl load
936 ELSEIF(numg>load_cyl_offset.and.numg<=last_offset) THEN
937 ! --------------------
938 ! /LOAD/PCYL option
939 ! get the global load segment id
940 global_segment_id = numg - load_cyl_offset
941 local_proc_id = loads%GLOBAL_SEGMENT_ID(global_segment_id,1) ! get the proc id where the segment is defined
942 local_segment_id = loads%GLOBAL_SEGMENT_ID(global_segment_id,2) ! get the local segment id (local to the proc P)
943 global_load_id = loads%GLOBAL_SEGMENT_ID(global_segment_id,3) ! get the global load id
944 local_load_id = loads_per_proc%INDEX_LOAD(global_load_id,2) ! get the local load id
945 ! --------
946 ! loop over the 4 nodes of the surfaces to save the adress
947 DO j=1,4
948 IF(n==loads_per_proc%LOAD_CYL(local_load_id)%SEGNOD(local_segment_id,j)) THEN
949 loads_per_proc%LOAD_CYL(local_load_id)%SEGMENT_ADRESS(j,local_segment_id) = cc_l
950 GO TO 100
951 ENDIF
952 ENDDO
953 ! --------
954 ! --------------------
955 ELSE
956 print *,'**error assadd2 unknown elem type'
957 ENDIF
958 ! --------------------
959 100 CONTINUE
960 ELSE
961C proc dist
962 ENDIF
963 ENDDO
964 ENDDO
965C
966Cply xfem
967C
968C
969C ADDCNEPXFEM_L and IADC_PXFE
970C
971 IF(iplyxfem > 0) THEN
972 addcnepxfem_l(1) = 1
973 cc_l = 0
974 nl_l = 0
975 DO i = 1, numnod_l
976
977 ng =nodglob(i)
978 n = inod_pxfem(ng)
979 IF(n > 0 ) THEN
980 nl_l = nl_l + 1
981 n1 = addcne_pxfem(n)
982 n2 = addcne_pxfem(n+1)
983 addcnepxfem_l(nl_l + 1) = addcnepxfem_l(nl_l) + n2 - n1
984 DO cc = n1, n2-1
985 numg0 = cne_pxfem(cc) ! ----> 1:numelc
986 n0 = iel_pxfem(numg0) !---> 1:el_pxfem
987 numl = cel_pxfem(n0) ! ----> proc local
988 numg = numg0 + numels + numelq
989 proc_l = cep(numg)+1
990
991 cc_l = cc_l + 1
992 procne_pxfem(cc_l) = proc_l
993C
994C Fill IADX if internal element
995C
996 IF (proc==proc_l) THEN
997C procloc
998 IF(numg<=numels+numelq+numelc) THEN
999 numg = numg - (numels+numelq)
1000 DO k=1,4
1001 shft = ishft(iun,k-1)
1002 testval =iand(shtag(numg),shft)
1003 IF (ixc(k+1,numg)==ng.AND.testval/=0) THEN
1004 iadc_pxfem(k,numl) = cc_l
1005 shtag(numg)=shtag(numg)-shft
1006cc GOTO 100
1007 ENDIF
1008 ENDDO
1009 ENDIF
1010cc 100 CONTINUE
1011C
1012 ENDIF
1013 ENDDO
1014 ENDIF
1015 ENDDO
1016 ENDIF
1017C------------------------------
1018C crack xfem for layered shell
1019C ADDCNECRKXFEM_L and IADC_CRKXFE
1020C------------------------------
1021 IF (icrack3d > 0) THEN
1022 iadc_crkxfem = 0
1023 crknodiad_l = 0
1024 addcnecrkxfem_l(1) = 1
1025 cc_l = 0
1026 nl_l = 0
1027 DO i = 1,numnod_l
1028 ng = nodglob(i)
1029cc N = INOD_CRKXFEM(NG)
1030cc IF(N > 0)THEN
1031 IF (inod_crk_l(i) > 0) THEN
1032 n = inod_crkxfem(ng) ! Num noeud systeme xfem global
1033 n1 = addcne_crkxfem(n) ! adresse global
1034 n2 = addcne_crkxfem(n+1)
1035 ! N2 - N1 = NB of std elements connects to the node n
1036 nl_l = nl_l + 1
1037 addcnecrkxfem_l(nl_l+1) = addcnecrkxfem_l(nl_l) + n2 - n1
1038c
1039 DO cc = n1,n2-1 ! global sky adr
1040 numg0 = cne_crkxfem(cc) ! -> 1:numelc+numeltg (elements systeme std)
1041 n0 = iel_crkxfem(numg0) ! -> 1:el_crkxfem (elements systeme xfem glob)
1042 numl = cel_crkxfem(n0) ! -> proc local (N element xfem local/proc)
1043cc NUMG = NUMG0 + NUMELS + NUMELQ
1044cc PROC_L = CEP(NUMG)+1
1045 proc_l = cep_crkxfem(n0) + 1 ! Proc of the SYS_XFEM element
1046C
1047 cc_l = cc_l + 1
1048 procne_crkxfem(cc_l) = proc_l
1049C
1050C Fill IADX if internal element
1051C
1052 IF (proc == proc_l) THEN
1053 IF (n0 <= ecrkxfec) THEN
1054 numg = numg0
1055 DO k=1,4
1056 shft = ishft(iun,k-1)
1057 testval = iand(shtag(numg),shft)
1058 IF (ixc(k+1,numg) == ng .AND. testval /= 0) THEN
1059 iadc_crkxfem(k,numl) = cc_l
1060c CNE_CRKXFEM_L (CC_L) = CNE_CRKXFEM (CC)!Contains NUMG0
1061 cne_crkxfem_l(cc_l) = numl ! Num sys xfem local par proc (ELCRK)
1062 crknodiad_l(cc_l) = crknodiad(cc)
1063 shtag(numg) = shtag(numg)-shft
1064 ENDIF
1065 ENDDO
1066 ELSEIF (n0 > ecrkxfec .AND. n0 <= ecrkxfec+ecrkxfetg) THEN
1067 numg = numg0 -numelc
1068 DO k=1,3
1069 shft = ishft(iun,k-1)
1070 testval = iand(tgtag(numg),shft)
1071 IF (ixtg(k+1,numg) == ng .AND. testval /= 0) THEN
1072 iadtg_crkxfem(k,numl) = cc_l
1073c CNE_CRKXFEM_L(CC_L) = CNE_CRKXFEM(CC)
1074 cne_crkxfem_l(cc_l) = numl + numelccrkxfe_l
1075 crknodiad_l(cc_l) = crknodiad(cc)
1076 tgtag(numg)=tgtag(numg)-shft
1077 ENDIF
1078 ENDDO
1079 ENDIF
1080 ENDIF ! PROC==PROC_L
1081 ENDDO ! CC = N1,N2-1
1082 ENDIF ! INOD_CRK_L(I) > 0
1083 ENDDO ! I = 1,NUMNOD_L
1084 ENDIF
1085C
1086C SPECIFIC RWALL Type SLIDING
1087C
1088 k = 0
1089 k_l = 0
1090 DO n = 1, nrwall
1091 n3 = 2*nrwall+n
1092 nsl=nprw(n)
1093 msr = nprw(n3)
1094 IF(msr/=0) THEN
1095 IF(nlocal(msr,proc)==1) THEN
1096 nsl_l = 0
1097 DO kk = 1, nsl
1098 nn = lprw(k+kk)
1099 IF(nlocal(nn,proc)==1) THEN
1100 nsl_l = nsl_l + 1
1101 main = 0
1102 DO p = 1, proc-1
1103 IF(nlocal(nn,p)==1) THEN
1104 GOTO 200
1105 ENDIF
1106 ENDDO
1107 main = 1
1108 200 IF(main==1) THEN
1109 iadwal(k_l+nsl_l) = kk
1110 ELSE
1111 iadwal(k_l+nsl_l) = 0
1112 ENDIF
1113 ENDIF
1114 ENDDO
1115 k_l = k_l + nsl_l
1116 ENDIF
1117 ENDIF
1118 k = k + nsl
1119 ENDDO
1120C
1121C SPECIFIC RBY
1122C
1123 IF(nskyrbk_l>0)THEN
1124 DO p = 1, nspmd
1125 idebrbk(p) = 0
1126 ENDDO
1127 k = 0
1128 nsl_l = 0
1129 DO n = 1, nrbykin
1130 msr=npby(1,n)
1131 nsl=npby(2,n)
1132 pmain = abs(dd_rby2(3,n))
1133 IF(nlocal(msr,proc)==1) THEN
1134 DO kk = 1, nsl
1135 nn = lpby(k+kk)
1136 IF(nlocal(nn,proc)==1)THEN
1137 nsl_l = nsl_l + 1
1138 main = 0
1139 DO p = 1, proc-1
1140 IF(nlocal(nn,p)==1)THEN
1141 GOTO 300
1142 ENDIF
1143 ENDDO
1144 main = 1
1145 300 IF(main==1) THEN
1146C numbering function of the pmain of previous rby
1147 iadrbk(nsl_l) = kk+idebrbk(pmain)
1148 ELSE
1149 iadrbk(nsl_l) = 0
1150 ENDIF
1151 ENDIF
1152 ENDDO
1153 ENDIF
1154 k = k + nsl
1155 idebrbk(pmain) = idebrbk(pmain) + nsl
1156 ENDDO
1157 ENDIF
1158CC
1159C
1160C Rigid material specifique
1161C
1162 IF(nskyrbmk_l>0)THEN
1163 DO p = 1, nspmd
1164 idebrbk(p) = 0
1165 ENDDO
1166 k = 0
1167 nsl_l = 0
1168 DO n = 1, nrbym
1169 msr=irbym(1,n)
1170 nsl=irbym(2,n)
1171 pmain = abs(dd_rbym2(3,n))
1172 IF(mod(front_rm(msr,proc),10)==1) THEN
1173 DO kk = 1, nsl
1174 nn = lcrbym(k+kk)
1175 IF(nlocal(nn,proc)==1)THEN
1176 nsl_l = nsl_l + 1
1177 main = 0
1178 DO p = 1, proc-1
1179 IF(nlocal(nn,p)==1)THEN
1180 GOTO 333
1181 ENDIF
1182 ENDDO
1183 main = 1
1184 333 IF(main==1) THEN
1185C numbering function of the pmain of previous rigid materials
1186 iadrbmk(nsl_l) = kk+idebrbk(pmain)
1187 ELSE
1188 iadrbmk(nsl_l) = 0
1189 ENDIF
1190 ENDIF
1191 ENDDO
1192 ENDIF
1193 k = k + nsl
1194 idebrbk(pmain) = idebrbk(pmain) + nsl
1195 ENDDO
1196 ENDIF
1197
1198CC
1199C
1200C Int 2 Specific
1201C
1202Cpseudo elt type 2
1203 IF(i2nsnt>0) THEN
1204 nsn_l = 0
1205 DO n = 1, ninter
1206 nty = ipari(7,n)
1207 IF (nty==2) THEN
1208 nrts = ipari(3,n)
1209 nrtm = ipari(4,n)
1210 nsn = ipari(5,n)
1211 nmn = ipari(6,n)
1212 DO i=1,nsn
1213 l = intbuf_tab(n)%IRTLM(i)
1214 k = intbuf_tab(n)%NSV(i)
1215 IF(nlocal(k,proc)==1) THEN
1216 DO p = 1, proc-1
1217 IF(nlocal(k,p)==1) GO TO 202
1218 ENDDO
1219 nsn_l = nsn_l + 1
1220 DO j=1,nir
1221 kk = intbuf_tab(n)%IRECTM((l-1)*4+j)
1222C I2TMP(J,I+OFF) = KK
1223 i2tmp(j,nsn_l) = kk
1224 END DO
1225 202 CONTINUE
1226 END IF
1227 END DO
1228 END IF
1229 END DO
1230 if(nsn_l/=i2nsn_l)print *,'error decomp i2 p/on'
1231C
1232 addcni2_l(1) = 1
1233 cc_l = 0
1234 DO i = 1, numnod_l
1235 n = nodglob(i)
1236 n1 = addcni2(n)
1237 n2 = addcni2(n+1)
1238 addcni2_l(i+1) = addcni2_l(i) + n2-n1
1239 DO cc = n1, n2-1
1240 numg = cni2(cc)
1241 numl = celi2(numg)
1242 proc_l = cepi2(numg)+1
1243 cc_l = cc_l + 1
1244 procni2(cc_l) = proc_l
1245C
1246C Fill IADI2 if internal element
1247C
1248 IF (proc==proc_l) THEN
1249 DO k = 1, nir
1250 IF(i2tmp(k,numl)==n) THEN
1251 iadi2(k,numl) = cc_l
1252 i2tmp(k,numl) = -n
1253 GO TO 222
1254 ENDIF
1255 END DO
1256 222 CONTINUE
1257 END IF
1258 END DO
1259 END DO
1260 ENDIF
1261C
1262C SPECIFIC RLINK
1263C
1264 k = 0
1265 k_l = 0
1266 DO i = 1, nlink
1267 nsl = nnlink(1,i)
1268 nsl_l = 0
1269 DO j = 1, nsl
1270 n = lllink(k+j)
1271 IF (nlocal(n,proc)==1)THEN
1272 nsl_l = nsl_l + 1
1273 iadll(k_l+nsl_l) = j
1274 ENDIF
1275 ENDDO
1276 k = k + nsl
1277 k_l = k_l + nsl_l
1278 ENDDO
1279C
1280C RBM specifique
1281C
1282 IF(nskyrbm_l>0)THEN
1283 DO p = 1, nspmd
1284 idebrbk(p) = 0
1285 ENDDO
1286 k = 0
1287 nsl_l = 0
1288 DO n = 1, nibvel
1289 nsl=ibvel(3,n)
1290 msr=ibvel(4,n)
1291 pmain = abs(dd_rbm2(3,n))
1292 IF(nlocal(msr,proc)==1) THEN
1293 DO kk = 1, nsl
1294 nn = lbvel(k+kk)
1295 IF(nlocal(nn,proc)==1)THEN
1296 nsl_l = nsl_l + 1
1297 main = 0
1298 DO p = 1, proc-1
1299 IF(nlocal(nn,p)==1)THEN
1300 GOTO 3000
1301 ENDIF
1302 ENDDO
1303 main = 1
1304 3000 IF(main==1) THEN
1305C numbering function of the pmain of previous rby
1306 iadrbm(nsl_l) = kk+idebrbk(pmain)
1307 ELSE
1308 iadrbm(nsl_l) = 0
1309 ENDIF
1310 ENDIF
1311 ENDDO
1312 ENDIF
1313 k = k + nsl
1314 idebrbk(pmain) = idebrbk(pmain) + nsl
1315 ENDDO
1316 ENDIF
1317C
1318C SPECIFIC RBE3 --- later ---
1319C
1320 IF(nskyrbe3_l>0)THEN
1321 ENDIF
1322CC
1323C
1324C Itet=2 of S10 specifique
1325C
1326C-----------------------------------------------
1327 IF(ns10e>0) THEN
1328C: N_L :NS10E_L, NSN_L compacted w/o sharering
1329 n_l = 0
1330 nsn_l = 0
1331 DO n = 1, ns10e
1332 k = icnds10(1,n)
1333 n1= icnds10(2,n)
1334 n2= icnds10(3,n)
1335 IF(nlocal(k,proc)==1.AND.itagnd(k)<=ns10e) THEN
1336 n_l = n_l +1
1337 DO p = 1, proc-1
1338 IF(nlocal(k,p)==1) GO TO 332
1339 ENDDO
1340c IF (CEPCND(N)==PROC-1) THEN
1341 nsn_l = nsn_l + 1
1342 icndtmp(1,nsn_l) = n1
1343 icndtmp(2,nsn_l) = n2
1344 icndtmp(3,nsn_l) = n_l
1345c END IF
1346 332 CONTINUE
1347 END IF
1348 END DO
1349 if(n_l/=ns10e_l)print *,'error decomp Itet2of S10 p/on',n_l,ns10e_l
1350c print *,'NSN_L,NS10E_L,LCNCND_L,NS10E=',NSN_L,NS10E_L,LCNCND_L,NS10E
1351C
1352 iadcnd(1:2,1:ns10e_l) = 0
1353 addcncnd_l(1) = 1
1354 cc_l = 0
1355 DO i = 1, numnod_l
1356 n = nodglob(i)
1357 n1 = addcncnd(n)
1358 n2 = addcncnd(n+1)
1359 addcncnd_l(i+1) = addcncnd_l(i) + n2-n1
1360 DO cc = n1, n2-1
1361 numg = cncnd(cc)
1362 IF (numg==0) cycle
1363 numl = celcnd(numg)
1364 proc_l = cepcnd(numg)+1
1365 cc_l = cc_l + 1
1366 procncnd(cc_l) = proc_l
1367
1368C Fill IADCND if internal element
1369
1370 IF (proc==proc_l) THEN
1371 DO k = 1, 2
1372 IF(icndtmp(k,numl)==n) THEN
1373 n_l = icndtmp(3,numl)
1374 iadcnd(k,n_l) = cc_l
1375 icndtmp(k,numl) = -n
1376 GO TO 223
1377 ENDIF
1378 END DO
1379 223 CONTINUE
1380 END IF
1381 END DO
1382 END DO
1383 ENDIF
1384C
1385C Interface 18
1386C
1387 IF(nbi18_l>0)THEN
1388 nn = 0
1389 DO n=1,ninter
1390 ity = ipari(7,n)
1391 inacti = ipari(22,n)
1392 IF((ity==7.OR.ity==22).AND.inacti==7)THEN ! interface 18 ! WE GO THROUGH HERE (INTER 18 or 22)
1393 nrts = ipari(3,n)
1394 nrtm = ipari(4,n)
1395 DO k=1,nrtm
1396C Flag tage used for inactive
1397 n1 = intbuf_tab(n)%IRECTM(4*(k-1)+1)
1398 n2 = intbuf_tab(n)%IRECTM(4*(k-1)+2)
1399 n3 = intbuf_tab(n)%IRECTM(4*(k-1)+3)
1400 n4 = intbuf_tab(n)%IRECTM(4*(k-1)+4)
1401 IF(nlocal(n1,proc)==1.AND.
1402 . nlocal(n2,proc)==1.AND.
1403 . nlocal(n3,proc)==1.AND.
1404 . nlocal(n4,proc)==1) THEN
1405 DO p = 1, proc-1
1406 IF(nlocal(n1,p)==1.AND.
1407 . nlocal(n2,p)==1.AND.
1408 . nlocal(n3,p)==1.AND.
1409 . nlocal(n4,p)==1) THEN
1410 GOTO 1300
1411 END IF
1412 END DO
1413 nn = nn + 1
1414 iadi18(nn) = k
1415 1300 CONTINUE
1416 END IF
1417 END DO
1418 END IF
1419 END DO
1420 END IF
1421C-----------------------------------------------
1422C Writing P/ON SPMD Tables
1423C-----------------------------------------------
1424C
1425C elements
1426 CALL write_i_c(addcne_l,numnod_l+1) ! ADSKY ?
1427 len_ia = len_ia + numnod_l+1
1428 CALL write_i_c(procne,lcne_l)
1429 len_ia = len_ia + lcne_l
1430C int 2
1431 IF(i2nsnt>0) THEN
1432 CALL write_i_c(addcni2_l,numnod_l+1)
1433 len_ia = len_ia + numnod_l+1
1434 ENDIF
1435 CALL write_i_c(procni2,lcni2_l)
1436 len_ia = len_ia + lcni2_l
1437C itet=2 of s10
1438 IF(ns10e_l>0) THEN
1439 CALL write_i_c(addcncnd_l,numnod_l+1)
1440 len_ia = len_ia + numnod_l+1
1441 ENDIF
1442 CALL write_i_c(procncnd,lcncnd_l)
1443 len_ia = len_ia + lcncnd_l
1444C adresses elements
1445 CALL write_i_c(iads,8*numels_l)
1446 len_ia = len_ia + 8*numels_l
1447 CALL write_i_c(iads10,6*numels10_l)
1448 len_ia = len_ia + 6*numels10_l
1449 CALL write_i_c(iads20,12*numels20_l)
1450 len_ia = len_ia +12*numels20_l
1451 CALL write_i_c(iads16,8*numels16_l)
1452 len_ia = len_ia + 8*numels16_l
1453 CALL write_i_c(iadq,4*numelq_l)
1454 len_ia = len_ia + 4*numelq_l
1455 CALL write_i_c(iadc,4*numelc_l)
1456 len_ia = len_ia + 4*numelc_l
1457 CALL write_i_c(iadt,2*numelt_l)
1458 len_ia = len_ia + 2*numelt_l
1459 CALL write_i_c(iadp,2*numelp_l)
1460 len_ia = len_ia + 2*numelp_l
1461 CALL write_i_c(iadr,3*numelr_l)
1462 len_ia = len_ia + 3*numelr_l
1463 CALL write_i_c(iadtg,3*numeltg_l)
1464 len_ia = len_ia + 3*numeltg_l
1465 CALL write_i_c(iadtg1,3*numeltg6_l)
1466 len_ia = len_ia + 3*numeltg6_l
1467 CALL write_i_c(iadmv,4*nnmv_l)
1468 len_ia = len_ia + 4*nnmv_l
1469 CALL write_i_c(iadib,4*nconld_l)
1470 len_ia = len_ia + 4*nconld_l
1471 CALL write_i_c(iadibcv,4*nconv_l)
1472 len_ia = len_ia + 4*nconv_l
1473 CALL write_i_c(iadibcr,4*nradia_l)
1474 len_ia = len_ia + 4*nradia_l
1475 CALL write_i_c(iadibfx,4*nfxflux_l)
1476 len_ia = len_ia + 4*nfxflux_l
1477 CALL write_i_c(iadload,llloadp_l)
1478 len_ia = len_ia + llloadp_l
1479C RW addresses
1480 CALL write_i_c(iadwal,nskyrw_l)
1481 len_ia = len_ia + nskyrw_l
1482C adresses RB Kin
1483 CALL write_i_c(iadrbk,nskyrbk_l)
1484 len_ia = len_ia + nskyrbk_l
1485C adresses int 2
1486 CALL write_i_c(iadi2,niskyi2_l)
1487 len_ia = len_ia + niskyi2_l
1488C Itet2 S10 addresses
1489 CALL write_i_c(iadcnd,2*ns10e_l)
1490 len_ia = len_ia + 2*ns10e_l
1491C Normal Force MV Addresses
1492 CALL write_i_c(iadmv2,nnmv_l)
1493 len_ia = len_ia + nnmv_l
1494C MV Addresses Left and Communicating MV
1495 CALL write_i_c(iadmv3,nnmvc_l)
1496 len_ia = len_ia + nnmvc_l
1497C RL Starter addresses
1498 CALL write_i_c(iadll,nskyll_l)
1499 len_ia = len_ia + nskyll_l
1500C adresses RBM starter
1501 CALL write_i_c(iadrbm,nskyrbm_l)
1502 len_ia = len_ia + nskyrbm_l
1503C adresses RBE3 starter
1504c CALL WRITE_I_C(IADRBE3,NSKYRBE3_L)
1505c LEN_IA = LEN_IA + NSKYRBE3_L
1506 CALL write_i_c(iadi18,nskyi18_l)
1507 len_ia = len_ia + nskyi18_l
1508C adresses rigid material Kin
1509 CALL write_i_c(iadrbmk,nskyrbmk_l)
1510 len_ia = len_ia + nskyrbmk_l
1511C
1512C elements
1513 IF(iplyxfem > 0 ) THEN
1514 CALL write_i_c(addcnepxfem_l,numnodpxfem_l+1)
1515 len_ia = len_ia + numnodpxfem_l+1
1516 CALL write_i_c(procne_pxfem,lcnepxfem_l)
1517 len_ia = len_ia + lcnepxfem_l
1518 CALL write_i_c(iadc_pxfem,4*numelcpxfem_l)
1519 len_ia = len_ia + 4*numelcpxfem_l
1520 ENDIF
1521C
1522C crack xfem for layered shell
1523C
1524 IF (icrack3d > 0) THEN
1525 CALL write_i_c(addcnecrkxfem_l,numnodcrkxfe_l+1)
1526 len_ia = len_ia + numnodcrkxfe_l+1
1527 CALL write_i_c(cne_crkxfem_l,lcnecrkxfem_l)
1528 len_ia = len_ia + lcnecrkxfem_l
1529 CALL write_i_c(procne_crkxfem,lcnecrkxfem_l)
1530 len_ia = len_ia + lcnecrkxfem_l
1531 CALL write_i_c(iadc_crkxfem,4*numelccrkxfe_l)
1532 len_ia = len_ia + 4*numelccrkxfe_l
1533 CALL write_i_c(iadtg_crkxfem,3*numeltgcrkxfe_l)
1534 len_ia = len_ia + 3*numeltgcrkxfe_l
1535 CALL write_i_c(crknodiad_l,lcnecrkxfem_l)
1536 len_ia = len_ia + lcnecrkxfem_l
1537 ENDIF
1538
1539 ! -----------------------
1540 ! EBCS option : adress for parith/on
1541 IF(local_nebcs>0) THEN
1542 DO i=1,local_nebcs
1543 CALL write_i_c(ebcs_parithon_l(i)%ELEM_ADRESS,4*ebcs_tab_loc_2%tab(i)%poly%nb_elem)
1544 len_ia = len_ia + 4*ebcs_tab_loc_2%tab(i)%poly%nb_elem
1545 ENDDO
1546 ENDIF
1547 ! -----------------------
1548c
1549 DEALLOCATE (soltag)
1550 DEALLOCATE (sol10tag)
1551 DEALLOCATE (sol20tag)
1552 DEALLOCATE (sol16tag)
1553 DEALLOCATE (quadtag)
1554 DEALLOCATE (shtag)
1555 DEALLOCATE (ttag)
1556 DEALLOCATE (ptag)
1557 DEALLOCATE (rtag)
1558 DEALLOCATE (tgtag)
1559 DEALLOCATE (tg6tag)
1560 DEALLOCATE (ibtag)
1561 DEALLOCATE (ibcvtag)
1562 DEALLOCATE (ibcrtag)
1563 DEALLOCATE (ibfxtag)
1564 DEALLOCATE (iltag)
1565 DEALLOCATE (tagig3d)
1566! -----------------------------
1567! deallocate 1d arrays
1568 DEALLOCATE( itagc,itagtg )
1569 DEALLOCATE( addcne_l,addcni2_l,addcncnd_l )
1570! deallocate IAD arrays
1571 DEALLOCATE( iads,iads10 )
1572 DEALLOCATE( iads16,iads20 )
1573 DEALLOCATE( iadq,iadc )
1574 DEALLOCATE( iadt,iadp )
1575 DEALLOCATE( iadr,iadtg )
1576 DEALLOCATE( iadib )
1577 DEALLOCATE( iadtg1,iadig3d )
1578! -----------------------------
1579 ! EBCS option : deallocation
1580 DEALLOCATE( ebcs_tag )
1581 IF(local_nebcs>0) THEN
1582 DO i=1,local_nebcs
1583 DEALLOCATE( ebcs_parithon_l(i)%ELEM_ADRESS )
1584 ENDDO
1585 ENDIF
1586 DEALLOCATE(ebcs_parithon_l)
1587 DEALLOCATE(procne)
1588 DEALLOCATE(itagib)
1589 DEALLOCATE(iadmv)
1590 DEALLOCATE(iadmv2)
1591 DEALLOCATE(iadmv3)
1592 DEALLOCATE(iadwal)
1593 DEALLOCATE(iadrbk)
1594 DEALLOCATE(iadi2)
1595 DEALLOCATE(i2tmp)
1596 DEALLOCATE(iadll)
1597 DEALLOCATE(procni2)
1598 DEALLOCATE(iadrbm)
1599 DEALLOCATE(iadi18)
1600 DEALLOCATE(iadibcv)
1601 DEALLOCATE(iadibfx)
1602 DEALLOCATE(iadrbmk)
1603 DEALLOCATE(iadibcr)
1604 DEALLOCATE(itagloadp)
1605 DEALLOCATE(iadload)
1606 DEALLOCATE(icndtmp)
1607 DEALLOCATE(procncnd)
1608 DEALLOCATE(iadcnd)
1609
1610 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
nlocal
integer function nlocal(n, p)
Definition ddtools.F:350
groupdef_mod
Definition groupdef_mod.F:668
main
int main(int argc, char *argv[])
Definition CMakeCCompilerId.c:841
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645