OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i22main_tri.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| i22main_tri ../engine/source/interfaces/intsort/i22main_tri.F
25!||--- called by ------------------------------------------------------
26!|| inttri ../engine/source/interfaces/intsort/inttri.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!|| check_sorting_criteria ../engine/source/interfaces/intsort/check_sorting_criteria.F90
31!|| i22buce ../engine/source/interfaces/intsort/i22buce.f
32!|| i22shell_getminmax ../engine/source/interfaces/intsort/i22main_tri.F
33!|| i22solid_getminmax ../engine/source/interfaces/intsort/i22main_tri.F
34!|| i22xsave ../engine/source/interfaces/intsort/i22xsave.F
35!|| imp_rnumcd ../engine/source/implicit/imp_int_k.F
36!|| my_barrier ../engine/source/system/machine.F
37!|| spmd_lagbounds_exch_i22 ../engine/source/mpi/interfaces/spmd_lagbounds_exch_i22.F
38!|| spmd_tri22vox ../engine/source/mpi/interfaces/spmd_tri22vox.F
39!|| spmd_tri22vox0 ../engine/source/mpi/interfaces/spmd_tri22vox0.F
40!|| spmd_tri7gat ../engine/source/mpi/interfaces/spmd_int.F
41!|| startime ../engine/source/system/timer_mod.F90
42!|| stoptime ../engine/source/system/timer_mod.F90
43!|| upgrade_multimp ../common_source/interf/upgrade_multimp.F
44!||--- uses -----------------------------------------------------
45!|| ale_connectivity_mod ../common_source/modules/ale/ale_connectivity_mod.F
46!|| check_sorting_criteria_mod ../engine/source/interfaces/intsort/check_sorting_criteria.F90
47!|| groupdef_mod ../common_source/modules/groupdef_mod.F
48!|| h3d_mod ../engine/share/modules/h3d_mod.F
49!|| i22bufbric_mod ../common_source/modules/interfaces/cut-cell-search_mod.F
50!|| i22tri_mod ../common_source/modules/interfaces/cut-cell-search_mod.F
51!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
52!|| message_mod ../engine/share/message_module/message_mod.F
53!|| multi_fvm_mod ../common_source/modules/ale/multi_fvm_mod.F90
54!|| timer_mod ../engine/source/system/timer_mod.F90
55!|| tri7box ../engine/share/modules/tri7box.F
56!||====================================================================
57 SUBROUTINE i22main_tri(TIMERS,
58 1 IPARI ,X ,V ,
59 2 MS ,NIN ,ITASK ,MWAG ,WEIGHT ,
60 3 ISENDTO ,IRCVFROM,RETRI ,IAD_ELEM,FR_ELEM ,
61 4 ITAB ,KINET ,TEMP ,NRTM_T ,RENUM ,
62 5 NSNFIOLD,ESHIFT ,NUM_IMP ,IND_IMP ,NODNX_SMS ,
63 6 IXS ,IGRBRIC ,ALE_CONNECTIVITY,INTBUF_TAB,
64 7 COUNT_REMSLV ,H3D_DATA,MULTI_FVM,NODADT_THERM)
65C============================================================================
66C M o d u l e s
67C-----------------------------------------------
68 USE timer_mod
69 USE tri7box
70 USE i22tri_mod
71 USE message_mod
72 USE intbufdef_mod
73 USE i22bufbric_mod
74 USE h3d_mod
75 USE groupdef_mod
76 USE multi_fvm_mod
77 USE ale_connectivity_mod
78 use check_sorting_criteria_mod , only : check_sorting_criteria
79C-----------------------------------------------
80C I m p l i c i t T y p e s
81C-----------------------------------------------
82#include "implicit_f.inc"
83#include "comlock.inc"
84C-----------------------------------------------
85C C o m m o n B l o c k s
86C-----------------------------------------------
87#include "com01_c.inc"
88#include "com04_c.inc"
89#include "com08_c.inc"
90#include "param_c.inc"
91#include "task_c.inc"
92#include "parit_c.inc"
93#include "timeri_c.inc"
94#include "inter22.inc"
95C common pour variable globale en memoire partagee
96 COMMON /i22mainc/bminma_lag,bminma_flu,result,nsnr,nsnrold,i_memg,
97 . curv_max_max
98 INTEGER RESULT,NSNR,NSNROLD,I_MEMG
99 my_real
100 . BMINMA_LAG(6), !dimensions domaine lagrangien local
101 . BMINMA_FLU(6), !dimensions domaine fluide local
102 . CURV_MAX_MAX
103C-----------------------------------------------
104C D u m m y A r g u m e n t s
105C-----------------------------------------------
106 TYPE(timer_) :: TIMERS
107 INTEGER NIN ,ITASK, RETRI, NRTM_T,ESHIFT,
108 . NUM_IMP ,IND_IMP(*),
109 . ITAB(*), KINET(*),
110 . IPARI(NPARI,NINTER), MWAG(*),
111 . ISENDTO(NINTER+1,*),IRCVFROM(NINTER+1,*),
112 . WEIGHT(*), IAD_ELEM(2,*) ,FR_ELEM(*),
113 . renum(numnod), nsnfiold(nspmd), nodnx_sms(*),
114 . ixs(nixs,*),nshell, count_remslv(*)
115 INTEGER , INTENT(IN) :: NODADT_THERM
116 my_real
117 . X(3,*), V(3,*), MS(*),TEMP(*)
118 TYPE(INTBUF_STRUCT_) INTBUF_TAB
119 TYPE(H3D_DATABASE) :: H3D_DATA
120 TYPE(MULTI_FVM_STRUCT), INTENT(INOUT) :: MULTI_FVM
121
122C-----------------------------------------------
123 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
124 TYPE(t_ale_connectivity), INTENT(IN) :: ALE_CONNECTIVITY
125C-----------------------------------------------
126C L o c a l V a r i a b l e s
127C-----------------------------------------------
128 INTEGER LOC_PROC, P,
129 . I, IP0, IP1, IP2, IP21, I_SK_OLD, I_STOK1,
130 . add1, nb_n_b, noint, inacti, multimp, igap, ifq,
131 . iad, j, nf, nl, i1, i2, rem_p(nspmd-1)
132 INTEGER ::
133 . NBRIC_G, !Nombre de brique dans tout le modele
134 . NBRIC_L, !Nombre de brique du domaine (non fragmentate sur les thread)
135 . nshel_g, !Nombre de facettes dans tout le modele
136 . nshel_l, !Nombre de facettes du domaine
137 . nshel_t, !Nombre de facettes du domaine associe au THREAD concerne
138 . nshelr_l !Nombre de facettes remote du domaine
139! . NSHELR_T !Nombre de facettes remote du domaine (pour le thread courant)
140 INTEGER
141 . ILD, NCONT, NCONTACT, INACTII, INACIMP, INTTH,
142 . I_MEM,CAND_N_OLD,IDUM1(1),
143 . ISU1, ISU2, NBF, NBL, IBID, COUNT_CAND, CT,INTFRIC
144 LOGICAL ::
145 . IS_CONTACT
146 my_real
147 . gap,maxbox,minbox,tzinf,
148 . xmaxl, ymaxl, zmaxl, xminl, yminl, zminl, gapmin, gapmax,
149 . c_maxl,bid,
150 . curv_max(nrtm_t),rdum1(1), stfe,
151 . bminma_and_r(6), !intersection fluid in local domain and remote lag faces
152 . bminma_and(6), !intersection fluid in local domain and all faces
153 . vel(4), vel_max
154 INTEGER :: NRTM,NSN,NTY,NMN
155 logical :: need_computation
156C-----------------------------------------------
157
158 ! --------------
159 ! check if the current interface needs to be sorted
160 call check_sorting_criteria( need_computation,nin,npari,nspmd,
161 . itask,ipari(1,nin),tt,intbuf_tab )
162 if( .not.need_computation ) return
163 ! --------------
164
165 i_memg = 0
166 i_mem = 0
167 is_contact=.false.
168
169C -------------------------------------------------------------
170C CRITERE DE RETRI
171C -------------------------------------------------------------
172 retri = 1
173C
174C -------------------------------------------------------------
175C INITIALISATIONS
176C -------------------------------------------------------------
177 nrtm =ipari(4,nin)
178 nsn =ipari(5,nin)
179 nmn =ipari(6,nin)
180 nty =ipari(7,nin)
181 noint =ipari(15,nin)
182 ncont =ipari(18,nin)
183 inacti =ipari(22,nin)
184 multimp=ipari(23,nin)
185 ncontact=multimp*ncont
186 !IFQ =IPARI(31,NIN)
187 i_sk_old=0
188 !INTTH = IPARI(47,NIN)
189 nsnrold = 0
190 gap =intbuf_tab%VARIABLES(2)
191 gapmin=intbuf_tab%VARIABLES(13)
192 gapmax=intbuf_tab%VARIABLES(16)
193 intbuf_tab%I_STOK(1)=0 !initialisation du nombre de condidat (II_STOK = INTBUF_TAB%I_STOK(1) )
194
195 !nombre d elements pour l interface (total, domaine, thread)
196 !---BRIQUES---!
197 nbric_g = ipari(32,nin)
198 isu1 = ipari(45,nin)
199 nbric_l = igrbric(isu1)%NENTITY
200!no IAD = IPARI(39,NIN) !ddsplit IPARI(39) <- IGRN(3) could change in ddsplit
201 !---SHELL---!
202 nshel_g = ipari(33,nin)
203 nshel_l = ipari(4,nin)
204 !ISU2 = IPARI(46,NIN)
205 !NSHEL_T = IGRN(2,ISU2)
206 nshel_t = nrtm_t
207 !---REMOTES---!
208 nsnr = 0
209 nshelr_l = 0
210 !NSHELR_T = NSNR
211
212 nirect_l = nshel_g !est un majorant de NSHEL_L+NSHELR_L
213
214C -------------------------------------------------------------
215C ALLOCATIONS
216C -------------------------------------------------------------
217 IF(itask==0)THEN
218 ALLOCATE (irect_l(siz_irect_l,nshel_g))
219 ALLOCATE(xmins(nbric_l))
220 ALLOCATE(ymins(nbric_l))
221 ALLOCATE(zmins(nbric_l))
222 ALLOCATE(xmaxs(nbric_l))
223 ALLOCATE(ymaxs(nbric_l))
224 ALLOCATE(zmaxs(nbric_l))
225 ALLOCATE(nsnr_g(nthread))
226 ALLOCATE(xmine(nshel_l))
227 ALLOCATE(ymine(nshel_l))
228 ALLOCATE(zmine(nshel_l))
229 ALLOCATE(xmaxe(nshel_l))
230 ALLOCATE(ymaxe(nshel_l))
231 ALLOCATE(zmaxe(nshel_l))
232 bminma_lag(1) = -ep30
233 bminma_lag(2) = -ep30
234 bminma_lag(3) = -ep30
235 bminma_lag(4) = ep30
236 bminma_lag(5) = ep30
237 bminma_lag(6) = ep30
238 dx22_min = ep30 !cinematic time step
239 v22_max = zero !cinematic time step
240 dt22_min = ep30 !cinematic time step
241 END IF
242
243 !cinematic time step
244 dx22min_l(itask) = ep30
245 v22max_l(itask) = zero
246
247 CALL my_barrier ! waiting for allocations
248
249 nsnr_g(1:nthread) = 0
250 loc_proc=ispmd+1
251
252C -------------------------------------------------------------
253C INITIALISATION DIMENSIONS DU DOMAINE LAGRANGIEN LOCAL
254C -------------------------------------------------------------
255 maxbox = intbuf_tab%VARIABLES(9)
256 minbox = intbuf_tab%VARIABLES(12)
257 tzinf = intbuf_tab%VARIABLES(8)
258
259C -------------------------------------------------------------
260C CALCUL BORNE DU DOMAINE LAGRANGIEN DU THREAD
261C -------------------------------------------------------------
262C eshift : decalage du groupe de facette, passage de NSHEL_T(thread) NSHEL_L(local)
263 CALL i22xsave(
264 1 x ,intbuf_tab%NSV ,intbuf_tab%MSR ,nsn ,nmn ,
265 2 itask ,intbuf_tab%XSAV ,xminl ,yminl ,zminl ,
266 3 xmaxl ,ymaxl ,zmaxl ,c_maxl ,curv_max ,
267 4 ipari(39,nin) ,intbuf_tab%IRECTM(1+4*eshift) ,nrtm_t )
268
269#include "lockon.inc"
270 bminma_lag(1) = max(bminma_lag(1),xmaxl)
271 bminma_lag(2) = max(bminma_lag(2),ymaxl)
272 bminma_lag(3) = max(bminma_lag(3),zmaxl)
273 bminma_lag(4) = min(bminma_lag(4),xminl)
274 bminma_lag(5) = min(bminma_lag(5),yminl)
275 bminma_lag(6) = min(bminma_lag(6),zminl)
276#include "lockoff.inc"
277 result = 0
278C BARRIER II_STOK et RESULT
279 CALL my_barrier !les bornes BMINMA doivent etre dans SPMD_TRI22VOX0 CELLE DU DOMAIN ET NON CELLE DU THREAD
280 !attendre les contributions de chaque thread
281
282C a conserver pour cas inacti est modifie sur p0
283 inacti=ipari(22,nin)
284 IF(itask==0)THEN
285 IF(abs(bminma_lag(6)-bminma_lag(3))>2*ep30.OR.
286 + abs(bminma_lag(5)-bminma_lag(2))>2*ep30.OR.
287 + abs(bminma_lag(4)-bminma_lag(1))>2*ep30)THEN
288 CALL ancmsg(msgid=87,anmode=aninfo,
289 . i1=noint,c1='(I22BUCE)')
290 CALL arret(2)
291 END IF
292
293 !extension du domaine lagrangien avec TZINF (verifier calcul de TZINF)
294 if(itask==0.and.ibug22_tri==1)print *,
295 . "applying TZINF extension to lag domain", tzinf
296
297 bminma_lag(1)=bminma_lag(1)+tzinf
298 bminma_lag(2)=bminma_lag(2)+tzinf
299 bminma_lag(3)=bminma_lag(3)+tzinf
300 bminma_lag(4)=bminma_lag(4)-tzinf
301 bminma_lag(5)=bminma_lag(5)-tzinf
302 bminma_lag(6)=bminma_lag(6)-tzinf
303
304 IF(nspmd > lrvoxelp)THEN
305 CALL ancmsg(msgid=36,anmode=aninfo,
306 . c1='(I22MAINTRI)')
307 CALL arret(2)
308 END IF
309 END IF
310
311
312C -------------------------------------------------------------
313C COMMUNICATION BORNES DES DOMAINES LAGRANGIENS
314C BMINMA_LAG_G(1:6) is global model data
315C -------------------------------------------------------------
316 IF(nspmd > 1) THEN
317 IF(itask==0)THEN
318 ALLOCATE(bminma_lag_spmd(6,nspmd))
319 IF(imonm > 0) CALL startime(timers,25)
320 CALL spmd_lagbounds_exch_i22(
321 . bminma_lag_spmd, bminma_lag, isendto ,ircvfrom , nin)
322 IF(imonm > 0) CALL stoptime(timers,25)
323
324 if(itask==0.and.ibug22_tri==1)print *, "BMINMA=",
325 . bminma_lag(4:6),bminma_lag(1:3)
326 j=1
327 !listing all remote proc in REM_P(1:NSPMD-1)
328C -------------------------------------------------------------
329C CALCUL DES DIMENSIONS DES DOMAINES :
330C + LAGRANGIENS REMOTES : BMINMA_LAG_R
331C + LAGRANGIEN GLOBAL : BMINMA_LAG_G
332C -------------------------------------------------------------
333 DO p=1,nspmd
334 IF(p==loc_proc)cycle
335 rem_p(j)=p
336 j=j+1
337 END DO
338 p=loc_proc
339 j=nspmd-1
340 !lagrangian bounds for all remote faces
341 bminma_lag_r(4) = minval(bminma_lag_spmd(4,rem_p(1:j)))
342 bminma_lag_r(5) = minval(bminma_lag_spmd(5,rem_p(1:j)))
343 bminma_lag_r(6) = minval(bminma_lag_spmd(6,rem_p(1:j)))
344 bminma_lag_r(1) = maxval(bminma_lag_spmd(1,rem_p(1:j)))
345 bminma_lag_r(2) = maxval(bminma_lag_spmd(2,rem_p(1:j)))
346 bminma_lag_r(3) = maxval(bminma_lag_spmd(3,rem_p(1:j)))
347 !lagrangian bounds for all faces in model
348 bminma_lag_g(4) = min(bminma_lag_r(4),bminma_lag_spmd(4,p))
349 bminma_lag_g(5) = min(bminma_lag_r(5),bminma_lag_spmd(5,p))
350 bminma_lag_g(6) = min(bminma_lag_r(6),bminma_lag_spmd(6,p))
351 bminma_lag_g(1) = max(bminma_lag_r(1),bminma_lag_spmd(1,p))
352 bminma_lag_g(2) = max(bminma_lag_r(2),bminma_lag_spmd(2,p))
353 bminma_lag_g(3) = max(bminma_lag_r(3),bminma_lag_spmd(3,p))
354 !---------------debug--------------!
355 if(itask==0.and.ibug22_tri==1)then
356 print *, ""
357 print *, "TZINF=", tzinf
358 print *, ""
359 print *, "---------------------------------------------------"
360 print *, "CURRENT DOMAIN =", loc_proc
361 print *, "--------BOUNDS FOR CURRENT LAG DOMAIN--------------"
362 print *, " BMINMAL=", bminma_lag(4:6),bminma_lag(1:3)
363 print *, "--------BOUNDS FOR ALL LAG DOMAINS-----------------"
364 DO i=1, nspmd
365 print *, "DOMAIN =", ispmd+1
366 print *, " BMINMAL=",
367 . bminma_lag_spmd(4:6,i),bminma_lag_spmd(1:3,i)
368 END DO
369 print *, "--------BOUNDS FOR AL REMOTE LAG DOMAINS-----------"
370 print *, " BMINMAL=", bminma_lag_r(4:6),bminma_lag_r(1:3)
371 print *, "--------BOUNDS FOR LAG GLOBAL DOMAINS--------------"
372 print *, " BMINMAL=", bminma_lag_g(4:6),bminma_lag_g(1:3)
373 print *, "---------------------------------------------------"
374 !print *, ""
375 end if
376 !---------------debug--------------!
377 END IF
378 ELSE
379 IF(itask==0) bminma_lag_g = bminma_lag
380 END IF
381
382C -------------------------------------------------------------
383C CALCUL DES DIMENSIONS DU DOMAINE FLUIDE LOCAL (multi-threading)
384C -------------------------------------------------------------
385 !Initialisation des bornes du domaine Fluide
386 bminma_flu(1) = -ep30
387 bminma_flu(2) = -ep30
388 bminma_flu(3) = -ep30
389 bminma_flu(4) = ep30
390 bminma_flu(5) = ep30
391 bminma_flu(6) = ep30
392
393
394 !IBUFSSG(IAD)[1:NBRIC_L] is multi-threaded
395 !computing MIN/MAX for 3D fluid elems
396 CALL i22solid_getminmax (
397 1 x, ixs, igrbric(isu1)%ENTITY, nbric_l,
398 2 itab, itask, nin )
399
400 CALL my_barrier
401
402 !Calcul des bornes du domaine Fluide
403#include "lockon.inc"
404 bminma_flu(1) = max(bminma_flu(1),maxval(xmaxs))
405 bminma_flu(2) = max(bminma_flu(2),maxval(ymaxs))
406 bminma_flu(3) = max(bminma_flu(3),maxval(zmaxs))
407 bminma_flu(4) = min(bminma_flu(4),minval(xmins))
408 bminma_flu(5) = min(bminma_flu(5),minval(ymins))
409 bminma_flu(6) = min(bminma_flu(6),minval(zmins))
410#include "lockoff.inc"
411
412 CALL my_barrier ! waiting for fluid local domain bounds definition (multi-threading)
413
414 IF(itask==0) THEN
415 bminma_flu(1) = bminma_flu(1)+tzinf
416 bminma_flu(2) = bminma_flu(2)+tzinf
417 bminma_flu(3) = bminma_flu(3)+tzinf
418 bminma_flu(4) = bminma_flu(4)-tzinf
419 bminma_flu(5) = bminma_flu(5)-tzinf
420 bminma_flu(6) = bminma_flu(6)-tzinf
421 !---------------debug--------------!
422 if(itask==0.and.ibug22_tri==1)then
423 print *, "--------LOCAL FLUID DOMAIN-------------"
424 print *, " BMINMAL_FLU=", bminma_flu(4:6),bminma_flu(1:3)
425 print *, "---------------------------------------------------"
426 print *, ""
427 end if
428 !---------------debug--------------!
429 END IF
430
431C -------------------------------------------------------------
432C CALCUL DES MIN/MAX DES FACETTES DE CHAQUE THREAD DU DOMAINE
433C -------------------------------------------------------------
434
435 !computing MIN/MAX for 2D elems
436 CALL i22shell_getminmax(
437 1 x, intbuf_tab%IRECTM(1+4*eshift), nrtm_t, intbuf_tab%STFM(1+eshift), itask,
438 2 itab, eshift, bminma_flu, tzinf )
439
440 CALL my_barrier !XMINE,XMAXE,... must be defined by all threads before going on.
441
442
443C -------------------------------------------------------------
444C RECHERCHE DANS LES AUTRES DOMAINES DES FACETTES A PROXIMITE
445C DU DOMAINE FLUIDE LOCAL (REMOTE). ALLOCATION DE XREM
446C -------------------------------------------------------------
447
448 IF(nspmd > 1) THEN
449
450 IF(itask==0) crvoxel(0:lrvoxel,0:lrvoxel,loc_proc)=0
451 CALL my_barrier ! waiting for crvoxel init.
452 IF (imonm > 0 .AND. itask == 0) CALL startime(timers,26)
453
454 CALL spmd_tri22vox0(
455 1 x, bminma_flu , nbric_l, ixs, igrbric(isu1)%ENTITY,
456 2 itask, itab , xmins , ymins, zmins ,
457 3 xmaxs, ymaxs , zmaxs ,bminma_lag_r, is_contact,
458 4 bminma_and_r )
459
460 CALL my_barrier ! all thread has to mark local domain Voxel before reading it above.
461
462 IF (imonm > 0 .AND. itask == 0) CALL stoptime(timers,26)
463 IF(itask==0)THEN
464 IF (imonm > 0 ) CALL startime(timers,25)
465 !CONTACT=TRUE si intersection non nulle entre domaine FLUIDE LOCAL / LAG DISTANTS
466 IF(is_contact) CALL spmd_tri22vox(
467 1 intbuf_tab%IRECTM ,nshel_l ,x ,v ,bminma_and_r, !envoyer les shell du domaine.
468 2 intbuf_tab%STFM ,nin ,isendto ,ircvfrom ,iad_elem ,
469 3 fr_elem ,nsnr ,itab ,itask )
470
471 IF (imonm > 0) CALL stoptime(timers,25)
472
473 nirect_l = nshel_l + nsnr !on avait un majorant de NSHEL_L+NSHELR_L, on connait mainteannt la taille exacte car NSHELR_L=NSNR (nb candidat remote)
474
475 ELSE
476 !verifier si contact avec intersection des domaines
477
478 END IF
479
480 CALL my_barrier ! attendre l'allocation et le remplissage de XREM pour remplir IRECT_L
481 nshelr_l = nsnr
482 !NSHELR_T = NSNR
483
484 END IF
485
486
487C -------------------------------------------------------------
488C DEFINITION DU TABLEAU GLOBAL DE COQUES (LOCAL + REMOTES)
489C -------------------------------------------------------------
490C IRECT_L( 1: 4, :) : Four Node ITAB( ID) : numero glolocal pour unicit avec XREM
491C IRECT_L( 5: 8, :) : X-coordinates
492C IRECT_L( 9:12, :) : Y-coordinates
493C IRECT_L(13:16, :) : Z-coordinates
494C IRECT_L(17:19, :) : Minimum X,Y,Z
495C IRECT_L(20:22, :) : Maximum X,Y,Z
496C IRECT_L(23 , :) : Stiffness
497C IRECT_L(24:26, :) : Lagrangian Velocity (mean)
498C IRECT_L( :,1+4*ESHIFT:4*ESHIFT+NRTM_T) : element data on current Thread
499C IRECT_L( :,NRTM+1:NRTM + NSNR) : remotes elements data
500
501! Filling with local data
502 DO i=0,nshel_t-1
503 ip1=i+1
504 j = eshift + ip1 !numero global (local+remote)
505 stfe = intbuf_tab%STFM(1+eshift+i) ! rigidite dans le groupe de shell du thread
506 irect_l(23 , j) = stfe ! Stiffness
507 !IF(STFE==ZERO) CYCLE
508 i1 = 1+4*eshift+4*i
509 i2 = i1+3
510 irect_l(1:4 , j) = itab(intbuf_tab%IRECTM(i1:i2)) ! User Nodes
511 irect_l(5:8 , j) = x(1,intbuf_tab%IRECTM(i1:i2)) ! X-coordinates
512 irect_l(9:12 , j) = x(2,intbuf_tab%IRECTM(i1:i2)) ! Y-coordinates
513 irect_l(13:16, j) = x(3,intbuf_tab%IRECTM(i1:i2)) ! Z-coordinates
514 irect_l(17:19, j) = (/xmine(j),ymine(j),zmine(j)/) ! Minimum X,Y,Z
515 irect_l(20:22, j) = (/xmaxe(j),ymaxe(j),zmaxe(j)/) ! Maximum X,Y,Z
516 irect_l(24, j) = sum(v(1,intbuf_tab%IRECTM(i1:i2)))/four ! X-Velocity (mean)
517 irect_l(25, j) = sum(v(2,intbuf_tab%IRECTM(i1:i2)))/four ! Y-Velocity (mean)
518 irect_l(26, j) = sum(v(3,intbuf_tab%IRECTM(i1:i2)))/four ! Z-Velocity (mean)
519
520 !cinematic time step
521 vel(1) = dot_product(v(1:3,intbuf_tab%IRECTM(i1+0)),v(1:3,intbuf_tab%IRECTM(i1+0)))
522 vel(2) = dot_product(v(1:3,intbuf_tab%IRECTM(i1+1)),v(1:3,intbuf_tab%IRECTM(i1+1)))
523 vel(3) = dot_product(v(1:3,intbuf_tab%IRECTM(i1+2)),v(1:3,intbuf_tab%IRECTM(i1+2)))
524 vel(4) = dot_product(v(1:3,intbuf_tab%IRECTM(i1+3)),v(1:3,intbuf_tab%IRECTM(i1+3)))
525 vel(1) = sqrt(vel(1))
526 vel(2) = sqrt(vel(2))
527 vel(3) = sqrt(vel(3))
528 vel(4) = sqrt(vel(4))
529 v22max_l(itask) = max(v22max_l(itask), maxval(vel) )
530
531 END DO
532
533! Filling with remote faces data
534 nf = 1+itask*nshelr_l/nthread
535 nl = (itask+1)*nshelr_l/nthread
536 DO i=nf,nl !1,NSNR
537 j = nshel_l+i
538 irect_l(1:4 , j) = xrem( 1:4,i) ! User Nodes
539 irect_l(5:8 , j) = xrem( 5:8,i) ! X-coordinates
540 irect_l(9:12 , j) = xrem( 9:12,i) ! Y-coordinates
541 irect_l(13:16 , j) = xrem(13:16,i) ! Z-coordinates
542 irect_l(17:19 , j) = xrem(17:19,i) ! Minimum X,Y,Z
543 irect_l(20:22 , j) = xrem(20:22,i) ! Maximum X,Y,Z
544 irect_l(23 , j) = xrem( 23,i) ! Stiffness (forcemment non nul)
545 irect_l(24:26 , j) = xrem(24:26,i) ! XYZ-Velocity (mean)
546
547 !missing SPMD cinematic time step
548 END DO
549!
550
551C--------------------------------------------------------------
552C CINEMATIC TIME STEP (MAXIMUM SPEED)
553C--------------------------------------------------------------
554 CALL my_barrier
555#include "lockon.inc"
556 v22_max = max(v22_max,v22max_l(itask))
557#include "lockoff.inc"
558
559C -------------------------------------------------------------
560
561C -------------------------------------------------------------
562
563 cand_n_old = intbuf_tab%I_STOK(1)
564 40 CONTINUE !verifier
565
566 ild = 0
567 nb_n_b = 1
568
569C -------------------------------------------------------------
570C CALCUL DES DIMENSIONS DOMAINE D'INTERET
571C INTERSECTION DE : {FLUIDE LOCAL} & {LAGRANGIEN GLOBAL}
572C -------------------------------------------------------------
573
574 bminma_and(1) = min(bminma_flu(1),bminma_lag_g(1))
575 bminma_and(2) = min(bminma_flu(2),bminma_lag_g(2))
576 bminma_and(3) = min(bminma_flu(3),bminma_lag_g(3))
577 bminma_and(4) = max(bminma_flu(4),bminma_lag_g(4))
578 bminma_and(5) = max(bminma_flu(5),bminma_lag_g(5))
579 bminma_and(6) = max(bminma_flu(6),bminma_lag_g(6))
580
581 if(itask==0.and.ibug22_tri==1)print *,
582 . "Faire test si dimension negative ",
583 . "=>candidat=0 ! ici ou dans i22trivox"
584
585
586 50 CALL my_barrier
587
588 IF (bminma_and(1)-bminma_and(4)<0)GOTO 999
589 IF (bminma_and(2)-bminma_and(5)<0)GOTO 999
590 IF (bminma_and(3)-bminma_and(6)<0)GOTO 999
591
592 iskip22 = 0
593
594C -------------------------------------------------------------
595C RECHERCHE DES COUPLES CANDIDATS POUR L'INTERACTION
596C -------------------------------------------------------------
597
598 IF (imonm > 0) CALL startime(timers,30)
599 CALL i22buce(
600 1 x ,intbuf_tab%IRECTM(1+4*eshift) ,intbuf_tab%NSV ,inacti ,iskip22 ,
601 2 nmn ,nshel_t ,nsn ,intbuf_tab%CAND_E ,intbuf_tab%CAND_N ,
602 3 gap ,noint ,intbuf_tab%I_STOK(1) ,ncontact ,bminma_and ,
603 4 tzinf ,maxbox ,minbox ,mwag ,curv_max ,
604 6 nb_n_b ,eshift ,ild ,ifq ,ibid ,
605 8 intbuf_tab%STFNS ,nin ,intbuf_tab%STFM(1+eshift) ,ipari(21,nin) ,
606 a nshelr_l ,ncont ,renum ,nsnrold ,
607 b gapmin ,gapmax ,curv_max_max ,num_imp ,
608 c intth ,itask ,intbuf_tab%VARIABLES(7) ,i_mem ,
609 d ixs ,igrbric(isu1)%ENTITY ,nbric_l ,itab ,nshel_l ,
610 e ale_connectivity ,ipari(1,nin) )
611C
612C Upgrade MultiMP
613 IF (i_mem == 2)THEN
614#include "lockon.inc"
615 i_memg = i_mem
616#include "lockoff.inc"
617 ENDIF
618C New barrier needed for Dynamic MultiMP
619 CALL my_barrier
620
621 IF(i_memg /=0)THEN
622!$OMP SINGLE
623 multimp = ipari(23,nin) + 4
624 CALL upgrade_multimp(nin,multimp,intbuf_tab)
625!$OMP END SINGLE
626 i_mem = 0
627 i_memg = 0
628 intbuf_tab%i_STOK(1) = cand_n_old
629 multimp = ipari(23,nin)
630 ncontact = multimp*ncont
631C eshift : decalage sur cand_e
632 GOTO 40
633 ENDIF
634
635 IF (imonm > 0) CALL stoptime(timers,30)
636C
637 count_cand = intbuf_tab%I_STOK(1)
638 ct = intbuf_tab%I_STOK(1)
639#include "lockon.inc"
640 intbuf_tab%VARIABLES(9) = min(maxbox,intbuf_tab%VARIABLES(9))
641 intbuf_tab%VARIABLES(12) = min(minbox,intbuf_tab%VARIABLES(12))
642 intbuf_tab%VARIABLES(8) = min(tzinf,intbuf_tab%VARIABLES(8))
643 intbuf_tab%VARIABLES(5) = intbuf_tab%VARIABLES(8)-gap
644 result = result + ild
645 lskyi_count = lskyi_count+count_cand*5
646 count_remslv(nin) = count_remslv(nin)+ct
647#include "lockoff.inc"
648
649
650
651C--------------------------------------------------------------
652C--------------------------------------------------------------
653 CALL my_barrier
654 IF (result/=0) THEN
655 CALL my_barrier
656 IF (itask==0) THEN
657C utile si on revient
658 intbuf_tab%I_STOK(1) = i_sk_old
659 result = 0
660 ENDIF
661 CALL my_barrier
662 ild = 0
663 maxbox = intbuf_tab%VARIABLES(9)
664 minbox = intbuf_tab%VARIABLES(12)
665 tzinf = intbuf_tab%VARIABLES(8)
666 GOTO 50
667 ENDIF
668C mise a - de dist temporairement pour reperage dans partie frontiere
669 IF(nspmd>1)THEN
670C mono tache
671!$omp single
672 IF (imonm > 0) CALL startime(timers,26)
673 intbuf_tab%VARIABLES(5) = -intbuf_tab%VARIABLES(5)
674C
675 intfric = 0
676 CALL spmd_tri7gat(
677 1 result ,nsn ,intbuf_tab%CAND_N,intbuf_tab%I_STOK(1),nin,
678 2 ipari(21,nin),nsnr,multimp ,nty,ipari(47,nin),
679 3 idum1 ,nsnfiold, ipari, h3d_data,intfric,
680 4 multi_fvm,nodadt_therm)
681 ipari(24,nin) = nsnr
682C
683 IF (num_imp>0)
684 . CALL imp_rnumcd(intbuf_tab%CAND_N,nin,nsn,num_imp,ind_imp )
685C
686 IF (imonm > 0) CALL stoptime(timers,26)
687!$OMP END SINGLE
688 END IF
689
690C--------------------------------------------------------------
691C DEALLOCATE
692C--------------------------------------------------------------
693
694 999 CONTINUE !JUMP IF DOMAINE INTERSECTION VIDE (PAS DE CANDIDATS)
695
696
697 IF(itask==0)THEN
698 !DEALLOCATE(IRECT_L)
699 DEALLOCATE(xmins)
700 DEALLOCATE(ymins)
701 DEALLOCATE(zmins)
702 DEALLOCATE(xmaxs)
703 DEALLOCATE(ymaxs)
704 DEALLOCATE(zmaxs)
705 DEALLOCATE(nsnr_g)
706 DEALLOCATE(xmine)
707 DEALLOCATE(ymine)
708 DEALLOCATE(zmine)
709 DEALLOCATE(xmaxe)
710 DEALLOCATE(ymaxe)
711 DEALLOCATE(zmaxe)
712 IF(ALLOCATED(bminma_lag_spmd))DEALLOCATE(bminma_lag_spmd)
713 END IF
714
715 RETURN
716 END
717
718!||====================================================================
719!|| i22solid_getminmax ../engine/source/interfaces/intsort/i22main_tri.F
720!||--- called by ------------------------------------------------------
721!|| i22main_tri ../engine/source/interfaces/intsort/i22main_tri.F
722!||--- uses -----------------------------------------------------
723!|| i22bufbric_mod ../common_source/modules/interfaces/cut-cell-search_mod.F
724!|| i22tri_mod ../common_source/modules/interfaces/cut-cell-search_mod.F
725!||====================================================================
726 SUBROUTINE i22solid_getminmax(
727 1 X, IXS, BUFBRIC, NBRIC,
728 2 ITAB, ITASK, NIN )
729C============================================================================
730C-----------------------------------------------
731C M o d u l e s
732C-----------------------------------------------
733 USE i22bufbric_mod
734 USE i22tri_mod
735C-----------------------------------------------
736C I m p l i c i t T y p e s
737C-----------------------------------------------
738#include "implicit_f.inc"
739C-----------------------------------------------
740C G l o b a l P a r a m e t e r s
741C-----------------------------------------------
742#include "task_c.inc"
743C-----------------------------------------------
744C C o m m o n B l o c k s
745C-----------------------------------------------
746C
747C-----------------------------------------------
748C D u m m y A r g u m e n t s
749C-----------------------------------------------
750 INTEGER ::
751 . IXS(NIXS,*), NBRIC,ITASK,
752 . BUFBRIC(NBRIC),ITAB(*)
753 INTEGER,INTENT(IN) :: NIN
754
755 my_real ::
756 . X(3,*)
757C-----------------------------------------------
758C L o c a l V a r i a b l e s
759C-----------------------------------------------
760 INTEGER IB, NE, TAB(8*NBRIC)
761 my_real
762 . xx(8), yy(8), zz(8), diag(4)
763 CHARACTER*8 KEY
764 INTEGER I,J, NBF, NBL
765C-----------------------------------------------
766
767!---------------debug---------------
768! DO I=0,NBRIC-1
769! J = 8*I
770! TAB(J+1:J+8)=ITAB(IXS(2:9,I+1))
771! END DO
772! KEY="BRIQUE_0"
773! write(KEY(8:8),'(i1.1)')ISPMD
774! print *, " ...marking node from local bricks "
775! print *, KEY//".txt"
776! CALL HM_MARKNOD ( ISPMD,ITASK, TAB, 8*NBRIC, KEY//".txt")
777! print *, " ...write OK"
778!---------------debug---------------
779
780 nbf = 1+itask*nbric/nthread
781 nbl = (itask+1)*nbric/nthread
782
783 DO ib=nbf,nbl !1,NBRIC
784 ne = bufbric(ib)
785 !-------------------------------------------!
786 ! Eight X-coordinates of the eight nodes !
787 !-------------------------------------------!
788 xx(1:8) = x(1,ixs(2:9,ne))
789 xmaxs(ib)= maxval(xx)
790 xmins(ib)= minval(xx)
791 !-------------------------------------------!
792 ! Eight Y-coordinates of the eight nodes !
793 !-------------------------------------------!
794 yy(1:8) = x(2,ixs(2:9,ne))
795 ymaxs(ib) = maxval(yy)
796 ymins(ib) = minval(yy)
797 !-------------------------------------------!
798 ! Eight Z-coordinates of the eight nodes !
799 !-------------------------------------------!
800 zz(1:8) = x(3,ixs(2:9,ne))
801 zmaxs(ib) = maxval(zz)
802 zmins(ib) = minval(zz)
803 !
804 ENDDO !IB=1,NBRIC
805
806 RETURN
807 END SUBROUTINE
808C-----------------------------------------------
809
810!||====================================================================
811!|| i22shell_getminmax ../engine/source/interfaces/intsort/i22main_tri.F
812!||--- called by ------------------------------------------------------
813!|| i22main_tri ../engine/source/interfaces/intsort/i22main_tri.f
814!||--- uses -----------------------------------------------------
815!|| i22tri_mod ../common_source/modules/interfaces/cut-cell-search_mod.F
816!|| tri7box ../engine/share/modules/tri7box.F
817!||====================================================================
818 SUBROUTINE i22shell_getminmax(
819 1 X, IRECT, NRTM, STFE, ITASK,
820 2 ITAB, ESHIFT, BMINMA, MARGE )
821C============================================================================
822C M o d u l e s
823C-----------------------------------------------
824 USE tri7box
825 USE i22tri_mod
826C-----------------------------------------------
827C I m p l i c i t T y p e s
828C-----------------------------------------------
829#include "implicit_f.inc"
830C-----------------------------------------------
831C D u m m y A r g u m e n t s
832C-----------------------------------------------
833 INTEGER NRTM,IRECT(4,NRTM), ITASK, ESHIFT
834 my_real
835 . x(3,*), stfe(nrtm), bminma(6), marge
836C-----------------------------------------------
837C L o c a l V a r i a b l e s
838C-----------------------------------------------
839 INTEGER ::
840 . IE, NE, N(4), NRTMR
841
842 my_real ::
843 . XX(4), YY(4), ZZ(4),
844 . xmin,ymin,zmin,
845 . xmax,ymax,zmax
846 INTEGER TAB(4*NRTM), J, I, ITAB(*)
847 CHARACTER*8 KEY
848C-----------------------------------------------
849
850!---------------debug---------------
851! DO I=0,NRTM-1
852! J = 4*I
853! TAB(J+1:J+4)=ITAB(IRECT(1:4,I+1))
854! END DO
855! KEY="FACETTE0"
856! write(KEY(8:8),'(i1.1)')ISPMD
857! print *, " ...marking node from local shells "
858! print *, KEY//".txt"
859! CALL HM_MARKNOD ( ISPMD,ITASK, TAB, 4*NRTM, KEY//".txt")
860! print *, " ...write OK"
861!---------------debug---------------
862
863!---------------debug---------------
864! !print *, "NRTMR=", NRTMR
865! DO I=0,NRTMR-1
866! J = 4*I
867! TAB(J+1)=ITAB(XREM( 8,I+1))
868! TAB(J+2)=ITAB(XREM(15,I+1))
869! TAB(J+3)=ITAB(XREM(22,I+1))
870! TAB(J+4)=ITAB(XREM(29,I+1))
871! END DO
872! KEY="REMOTE_0"
873! write(KEY(8:8),'(i1.1)')ISPMD
874! print *, " ...marking node from remote shells "
875! print *, KEY//".txt"
876! CALL HM_MARKNOD ( ISPMD,ITASK, TAB, 4*NRTMR, KEY//".txt")
877! print *, " ...write OK"
878!---------------debug---------------
879
880 ! On verifie au passage que les face locales sont a proximit (marge) du domaine local fluide (bminma)
881 xmin = bminma(4)-marge
882 ymin = bminma(5)-marge
883 zmin = bminma(6)-marge
884 xmax = bminma(1)+marge
885 ymax = bminma(2)+marge
886 zmax = bminma(3)+marge
887
888 DO ie=1,nrtm
889 IF(stfe(ie)==zero)cycle
890 j = ie+eshift
891 n(1:4) = irect(1:4,ie)
892 !-------------------------------------------!
893 ! Eight X-coordinates of the eight nodes !
894 !-------------------------------------------!
895 xx(1:4) = x(1,n(1:4))
896 xmaxe(j) = maxval(xx)
897 xmine(j) = minval(xx)
898 !-------------------------------------------!
899 ! Eight Y-coordinates of the eight nodes !
900 !-------------------------------------------!
901 yy(1:4) = x(2,n(1:4))
902 ymaxe(j) = maxval(yy)
903 ymine(j) = minval(yy)
904 !-------------------------------------------!
905 ! Eight Z-coordinates of the eight nodes !
906 !-------------------------------------------!
907 zz(1:4) = x(3,n(1:4))
908 zmaxe(j) = maxval(zz)
909 zmine(j) = minval(zz)
910 ENDDO !IB=1,NRTM
911
912 RETURN
913 END SUBROUTINE
914C-----------------------------------------------
915
i22buce
subroutine i22buce(x, irect, nsv, inacti, iskip, nmn, nshel_t, nsn, cand_e, cand_b, gap, noint, ii_stok, ncontact, bminma, tzinf, maxbox, minbox, mwag, curv_max, nb_n_b, eshift, ild, ifq, ifpen, stfn, nin, stf, igap, nshelr_l, ncont, renum, nsnrold, gapmin, gapmax, curv_max_max, num_imp, intth, itask, bgapsmx, i_mem, ixs, bufbric, nbric, itab, nshel_l, ale_connectivity, ipari)
Definition i22buce.F:55
i22shell_getminmax
subroutine i22shell_getminmax(x, irect, nrtm, stfe, itask, itab, eshift, bminma, marge)
Definition i22main_tri.F:821
i22main_tri
subroutine i22main_tri(timers, ipari, x, v, ms, nin, itask, mwag, weight, isendto, ircvfrom, retri, iad_elem, fr_elem, itab, kinet, temp, nrtm_t, renum, nsnfiold, eshift, num_imp, ind_imp, nodnx_sms, ixs, igrbric, ale_connectivity, intbuf_tab, count_remslv, h3d_data, multi_fvm, nodadt_therm)
Definition i22main_tri.F:65
i22solid_getminmax
subroutine i22solid_getminmax(x, ixs, bufbric, nbric, itab, itask, nin)
Definition i22main_tri.F:729
i22xsave
subroutine i22xsave(x, nsv, msr, nsn, nmn, itask, xsav, xmin, ymin, zmin, xmax, ymax, zmax, c_max, curv_max, icurv, irect, nrtm_t)
Definition i22xsave.F:33
imp_rnumcd
subroutine imp_rnumcd(cand_n, nin, nsn, num_imp, index)
Definition imp_int_k.F:1542
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:272
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
ale_connectivity_mod
Definition ale_connectivity_mod.F:223
groupdef_mod
Definition groupdef_mod.F:662
h3d_mod
Definition h3d_mod.F:308
i22bufbric_mod
Definition cut-cell-search_mod.F:95
i22tri_mod
Definition cut-cell-search_mod.F:212
i22tri_mod::ibug22_tri
integer ibug22_tri
Definition cut-cell-search_mod.F:231
i22tri_mod::nirect_l
integer nirect_l
Definition cut-cell-search_mod.F:447
i22tri_mod::siz_irect_l
integer siz_irect_l
Definition cut-cell-search_mod.F:449
i22tri_mod::nsnr_g
integer, dimension(:), allocatable nsnr_g
Definition cut-cell-search_mod.F:452
i22tri_mod::iskip22
integer iskip22
Definition cut-cell-search_mod.F:520
message_mod
Definition message_mod.F:1249
tri7box::crvoxel
integer, dimension(0:lrvoxel, 0:lrvoxel) crvoxel
Definition tri7box.F:56
tri7box::lrvoxelp
integer lrvoxelp
Definition tri7box.F:522
tri7box::lrvoxel
integer lrvoxel
Definition tri7box.F:54
spmd_tri7gat
subroutine spmd_tri7gat(result, nsn, cand_n, i_stok, nin, igap, nsnr, multimp, ity, intth, ilev, nsnfiold, ipari, h3d_data, intfric, multi_fvm, nodadt_therm)
Definition spmd_int.F:3002
spmd_lagbounds_exch_i22
subroutine spmd_lagbounds_exch_i22(bminmal_spmd, bminmal, isendto, ircvfrom, nin)
Definition spmd_lagbounds_exch_i22.F:35
spmd_tri22vox0
subroutine spmd_tri22vox0(x, bminma_flu_l, nbric, ixs, bufbric, itask, itab, xmins, ymins, zmins, xmaxs, ymaxs, zmaxs, bminma_lag_r, is_contact, bminma_and)
Definition spmd_tri22vox0.F:36
spmd_tri22vox
subroutine spmd_tri22vox(irectm, nrtm, x, v, bminmal, stife, nin, isendto, ircvfrom, iad_elem, fr_elem, nshelr, itab, itask)
Definition spmd_tri22vox.F:42
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
nl
character *2 function nl()
Definition message.F:2354
arret
subroutine arret(nn)
Definition arret.F:87
my_barrier
subroutine my_barrier
Definition machine.F:31
startime
subroutine startime(event, itask)
Definition timer.F:93
stoptime
subroutine stoptime(event, itask)
Definition timer.F:135
upgrade_multimp
subroutine upgrade_multimp(ni, multimp_parameter, intbuf_tab)
Definition upgrade_multimp.F:48