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

Go to the source code of this file.

Functions/Subroutines

subroutine sms_rbe3_nodxi (irbe3, lrbe3, nodxi_sms, iad_m, fr_m)
subroutine sms_rbe3t1 (irbe3, lrbe3, x, a, frbe3, skew, weight, iad_m, fr_m, fr_mpon, rsum, rsum_pon, r3size)
subroutine sms_rbe3t2 (irbe3, lrbe3, x, a, frbe3, skew, r, prec_sms3)
subroutine sms_rbe3_prec (irbe3, lrbe3, x, diag_sms, diag_sms3, frbe3, skew, weight, iad_m, fr_m, fr_mpon, rsum, rsum_pon, r3size)
subroutine sms_rbe3_1 (irbe3, lrbe3, x, a, frbe3, skew, weight, jt, irotg, max_m, am, nmt0, iadmp)
subroutine sms_rbe3_2 (irbe3, lrbe3, a, weight, da, nmt, iml, jt)
subroutine sms_rbe3_3 (irbe3, lrbe3, diag_sms3, weight, da, nmt, iml, jt)

Function/Subroutine Documentation

◆ sms_rbe3_1()

subroutine sms_rbe3_1 ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
x,
a,
frbe3,
skew,
integer, dimension(*) weight,
integer, dimension(3,*) jt,
integer irotg,
integer max_m,
am,
integer nmt0,
integer, dimension(*) iadmp )

Definition at line 459 of file sms_rbe3.F.

463C-----------------------------------------------
464C I m p l i c i t T y p e s
465C-----------------------------------------------
466#include "implicit_f.inc"
467C-----------------------------------------------
468C C o m m o n B l o c k s
469C-----------------------------------------------
470#include "com04_c.inc"
471#include "param_c.inc"
472C-----------------------------------------------
473C D u m m y A r g u m e n t s
474C-----------------------------------------------
475 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*)
476 INTEGER MAX_M,IROTG,JT(3,*),NMT0,IADMP(*)
477C REAL
478 my_real
479 . x(3,*), a(3,*), frbe3(*),skew(*), am(3,*)
480C-----------------------------------------------
481C L o c a l V a r i a b l e s
482C-----------------------------------------------
483 INTEGER I, J, N, NS ,NML, IAD, IROT, IADS, NN, K
484C REAL
485 my_real
486 . fns(3), sfd, smd
487C REAL
488 my_real,
489 . DIMENSION(:,:,:),ALLOCATABLE :: fdstnb ,mdstnb
490C-----------------------------------------------
491 iads = nmt0
492 ALLOCATE(fdstnb(3,6,max_m))
493 IF (irotg>0) ALLOCATE(mdstnb(3,6,max_m))
494C---
495 DO n=1,nrbe3
496 iad = irbe3(1,n)
497 ns = irbe3(3,n)
498 nml = irbe3(5,n)
499 irot =irbe3(6,n)
500 IF (ns>0) THEN
501 CALL rbe3cl(lrbe3(iad+1),lrbe3(iads+iad+1),ns ,x ,
502 . frbe3(6*iad+1),skew ,nml ,irot ,fdstnb ,
503 . mdstnb ,irbe3(2,n))
504
505 DO j = 1,3
506 nn = jt(j,n)*weight(ns)
507 fns(j) = a(j,ns)*nn
508 ENDDO
509C---not to add supplementary mass globally
510 CALL mfac_rbe3(fdstnb,mdstnb,nml ,irotg,sfd ,smd)
511 DO i=1,nml
512 k = iadmp(iad+i)
513 DO j = 1,3
514 am(1,k) = am(1,k)+fdstnb(1,j,i)*fns(j)
515 am(2,k) = am(2,k)+fdstnb(2,j,i)*fns(j)
516 am(3,k) = am(3,k)+fdstnb(3,j,i)*fns(j)
517 ENDDO
518 ENDDO
519C---
520 END IF ! IF (NS>0) THEN
521 ENDDO
522C
523 DEALLOCATE(fdstnb)
524 IF (irotg>0) DEALLOCATE(mdstnb)
525C
526 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
rbe3cl
subroutine rbe3cl(inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, fdstnb, mdstnb)
Definition kinchk.F:1586
mfac_rbe3
subroutine mfac_rbe3(fdstnb, mdstnb, nml, irot, sf, sm)
Definition rbe3f.F:2104

◆ sms_rbe3_2()

subroutine sms_rbe3_2 ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
a,
integer, dimension(*) weight,
double precision, dimension(6,3,*) da,
integer nmt,
integer, dimension(*) iml,
integer, dimension(3,nrbe3) jt )

Definition at line 534 of file sms_rbe3.F.

536C-----------------------------------------------
537C I m p l i c i t T y p e s
538C-----------------------------------------------
539#include "implicit_f.inc"
540C-----------------------------------------------
541C C o m m o n B l o c k s
542C-----------------------------------------------
543#include "com04_c.inc"
544#include "param_c.inc"
545C-----------------------------------------------
546C D u m m y A r g u m e n t s
547C-----------------------------------------------
548 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*),IML(*) ,NMT,
549 . JT(3,NRBE3)
550C REAL
551 my_real
552 . a(3,*)
553 double precision
554 . da(6,3,*)
555C-----------------------------------------------
556C L o c a l V a r i a b l e s
557C-----------------------------------------------
558 INTEGER I, J, M, N, NS
559C REAL
560 my_real
561 . ax,ay,az
562C======================================================================|
563#include "vectorize.inc"
564 DO i=1,nmt
565 m = iml(i)
566 ax = zero
567 ay = zero
568 az = zero
569 DO j=1,6
570 ax = ax + da(j,1,i)
571 ay = ay + da(j,2,i)
572 az = az + da(j,3,i)
573 END DO
574 a(1,m) = a(1,m)+ ax
575 a(2,m) = a(2,m)+ ay
576 a(3,m) = a(3,m)+ az
577 END DO
578C---
579 DO n=1,nrbe3
580 ns = irbe3(3,n)
581 IF(ns/=0)THEN
582C Reset residu for secnd node
583 DO j = 1,3
584 IF(jt(j,n)/=0)a(j,ns)=zero
585 END DO
586 END IF
587 END DO
588C---
589 RETURN

◆ sms_rbe3_3()

subroutine sms_rbe3_3 ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
diag_sms3,
integer, dimension(*) weight,
double precision, dimension(6,3,*) da,
integer nmt,
integer, dimension(*) iml,
integer, dimension(3,nrbe3) jt )

Definition at line 597 of file sms_rbe3.F.

599C-----------------------------------------------
600C I m p l i c i t T y p e s
601C-----------------------------------------------
602#include "implicit_f.inc"
603C-----------------------------------------------
604C C o m m o n B l o c k s
605C-----------------------------------------------
606#include "com04_c.inc"
607#include "param_c.inc"
608C-----------------------------------------------
609C D u m m y A r g u m e n t s
610C-----------------------------------------------
611 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*),IML(*) ,NMT, JT(3,NRBE3)
612 my_real diag_sms3(3,*)
613 DOUBLE PRECISION DA(6,3,*)
614C-----------------------------------------------
615C L o c a l V a r i a b l e s
616C-----------------------------------------------
617 INTEGER I, J, K, M, N, NS
618C REAL
619 my_real
620 . dd
621C======================================================================|
622#include "vectorize.inc"
623 DO i=1,nmt
624 m = iml(i)
625 DO j=1,3
626 dd=diag_sms3(j,m)
627 DO k=1,6
628 dd = dd + da(k,j,i)
629 END DO
630 diag_sms3(j,m) = dd
631 END DO
632 END DO
633C---
634 RETURN

◆ sms_rbe3_nodxi()

subroutine sms_rbe3_nodxi ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) nodxi_sms,
integer, dimension(*) iad_m,
integer, dimension(*) fr_m )

Definition at line 33 of file sms_rbe3.F.

35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39#include "comlock.inc"
40C-----------------------------------------------
41C C o m m o n B l o c k s
42C-----------------------------------------------
43#include "com01_c.inc"
44#include "com04_c.inc"
45#include "param_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER IRBE3(NRBE3L,*),LRBE3(*),NODXI_SMS(*), IAD_M(*), FR_M(*)
50C REAL
51C-----------------------------------------------
52C L o c a l V a r i a b l e s
53C-----------------------------------------------
54 INTEGER N, I, M, JT(3,NRBE3), JR(3,NRBE3), IAD, NS, NML, FIN,
55 . FINFIN, ICOM, IROTG, MAX_M
56C-----------------------------------------------
57 CALL prerbe3(irbe3 ,max_m , irotg,jt ,jr )
58 icom = iad_m(nspmd+1)-iad_m(1)
59c IF (NSPMD>1)CALL SPMD_MAX_II(IROTG,IAD_M,ICOM)
60C-----
61C when a secnd node belongs to a domain, all main nodes also belong to the domain !!!
62C-----
63 finfin=0
64 DO WHILE(finfin==0)
65 finfin=1
66C
67C going up
68 fin=0
69 DO WHILE(fin==0)
70 fin=1
71 DO n=1,nrbe3
72 iad = irbe3(1,n)
73 ns = irbe3(3,n)
74 IF (ns==0) cycle
75 nml = irbe3(5,n)
76 IF(jt(1,n)+jt(2,n)+jt(3,n)/=0)THEN
77 DO i=1,nml
78 m = lrbe3(iad+i)
79 IF(nodxi_sms(ns)/=0.AND.nodxi_sms(m)==0) THEN
80 nodxi_sms(m)=1
81 fin=0
82 END IF
83 ENDDO
84 END IF
85 END DO
86 END DO
87C
88 IF (icom>0) THEN
89 CALL spmd_exch_rbe3_nodnx(
90 1 nodxi_sms,fr_m ,iad_m ,iad_m(nspmd+1) )
91 END IF
92C
93C going down
94 fin=0
95 DO WHILE(fin==0)
96 fin=1
97 DO n=1,nrbe3
98 iad = irbe3(1,n)
99 ns = irbe3(3,n)
100 IF (ns==0) cycle
101 nml = irbe3(5,n)
102 IF(jt(1,n)+jt(2,n)+jt(3,n)/=0)THEN
103 DO i=1,nml
104 m = lrbe3(iad+i)
105 IF(nodxi_sms(m)/=0.AND.nodxi_sms(ns)==0) THEN
106 nodxi_sms(ns)=1
107 fin=0
108C
109C a climb-up is still needed
110 finfin=0
111 EXIT
112 END IF
113 ENDDO
114 END IF
115 END DO
116 END DO
117C
118 IF (nspmd>1)CALL spmd_max_ii(finfin,iad_m,icom)
119 END DO ! DO WHILE(FINFIN==0)
120C
121 RETURN
spmd_max_ii
subroutine spmd_max_ii(nmax, iad_elem, tsize)
Definition imp_spmd.F:4810
prerbe3
subroutine prerbe3(irbe3, max_m, irotg, jt, jr)
Definition kinchk.F:1494
spmd_exch_rbe3_nodnx
subroutine spmd_exch_rbe3_nodnx(nodnx_sms, fr_m, iad_m, lcomm)
Definition spmd_sms.F:1256

◆ sms_rbe3_prec()

subroutine sms_rbe3_prec ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
x,
diag_sms,
diag_sms3,
frbe3,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_m,
integer, dimension(*) fr_m,
integer, dimension(*) fr_mpon,
rsum,
double precision, dimension(*) rsum_pon,
integer r3size )

Definition at line 345 of file sms_rbe3.F.

349C-----------------------------------------------
350C I m p l i c i t T y p e s
351C-----------------------------------------------
352#include "implicit_f.inc"
353C-----------------------------------------------
354C C o m m o n B l o c k s
355C-----------------------------------------------
356#include "com01_c.inc"
357#include "com04_c.inc"
358#include "param_c.inc"
359#include "tabsiz_c.inc"
360C-----------------------------------------------
361C D u m m y A r g u m e n t s
362C-----------------------------------------------
363 INTEGER IRBE3(NRBE3L,*), LRBE3(*), WEIGHT(*), IAD_M(*), FR_M(*),
364 . FR_MPON(*),R3SIZE
365C REAL
366 my_real
367 . x(3,*), diag_sms(*), diag_sms3(*), frbe3(*), skew(*), rsum(*)
368 double precision
369 . rsum_pon(*)
370C-----------------------------------------------
371C L o c a l V a r i a b l e s
372C-----------------------------------------------
373 INTEGER I, J, N, MAX_M,IROTG,JT(3,NRBE3),JR(3,NRBE3),IERR,NMT,
374 . IADA,IADMS,IADFN,IADAR,IADIN,IADFR,IADM0,IADI0,IADL,
375 . IPA,IPMS,IPFN,IPAR,IPIN,IPFR,NMP,IADLP,NS,NML,ICOM,
376 . IADLP1,IADM1,IADI1,NMT0,IADMP(SLRBE3/2),IML(SLRBE3/2),
377 . ISIZE
378C REAL
379C------------allacation will be removed to ini_ uniforming smp spmd in v11
380C my_real
381C . , DIMENSION(:), ALLOCATABLE :: RSUM
382C DOUBLE PRECISION
383C . , DIMENSION(:), ALLOCATABLE :: RSUM_PON
384C======================================================================|
385 nmt0 = slrbe3/2
386 CALL prerbe3(irbe3 ,max_m , irotg,jt ,jr )
387 icom = iad_m(nspmd+1)-iad_m(1)
388c IF (NSPMD>1)CALL SPMD_MAX_II(IROTG,IAD_M,ICOM)
389 IF (r3size>5)irotg = 1
390C
391 IF (nmt0>0) THEN
392 CALL prerbe3p(irbe3 ,lrbe3 ,iadmp ,iml , nmt )
393 iada=1
394 iadms=iada+3*nmt
395 iadfn=iadms+nmt
396 IF (irotg>0) THEN
397 iadar=iadfn+nmt
398 iadin=iadar+3*nmt
399 iadfr=iadin+nmt
400 ELSE
401 iadar=iadfn
402 iadin=iadar
403 iadfr=iadin
404 ENDIF
405 iadl=iadfr+nmt
406C
407C ALLOCATE(RSUM(IADL),STAT=IERR)
408 CALL zero1(rsum,iadl)
409 CALL sms_rbe3_1(
410 1 irbe3 ,lrbe3 ,x ,diag_sms3,frbe3 ,
411 2 skew ,weight,jt ,irotg ,max_m ,
412 3 rsum(iada),nmt0 ,iadmp )
413C
414 nmp = 6*nmt
415 ipa=1
416 ipms=ipa+3*nmp
417 ipfn=ipms+nmp
418 IF (irotg>0) THEN
419 ipar=ipfn+nmp
420 ipin=ipar+3*nmp
421 ipfr=ipin+nmp
422 ELSE
423 ipar=ipfn
424 ipin=ipar
425 ipfr=ipin
426 ENDIF
427 iadlp=ipfr+nmp
428C version spmd p/on
429C ALLOCATE(RSUM_PON(IADLP),STAT=IERR)
430C RSUM_PON=ZERO
431 CALL foat_to_6_float(1 ,nmt*3 ,rsum(iada) ,rsum_pon(ipa) )
432 IF (icom>0) THEN
433 isize=3
434 CALL spmd_exch_rbe3_a_pon(
435 . rsum_pon(ipa),fr_mpon,iad_m ,iad_m(nspmd+1),isize)
436 ENDIF
437C
438C Routine assemblage parith/ON
439C
440 CALL sms_rbe3_3(irbe3 ,lrbe3 ,diag_sms3,weight,rsum_pon(ipa),
441 2 nmt ,iml ,jt )
442C DEALLOCATE(RSUM_PON)
443C
444C DEALLOCATE(RSUM)
445 END IF ! IF (NMT>0)
446C---
447 RETURN
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1481
foat_to_6_float
subroutine foat_to_6_float(jft, jlt, f, f6)
Definition parit.F:225
prerbe3p
subroutine prerbe3p(irbe3, lrbe3, ad_m, iml, nmt)
Definition rbe3f.F:1983
sms_rbe3_3
subroutine sms_rbe3_3(irbe3, lrbe3, diag_sms3, weight, da, nmt, iml, jt)
Definition sms_rbe3.F:599
sms_rbe3_1
subroutine sms_rbe3_1(irbe3, lrbe3, x, a, frbe3, skew, weight, jt, irotg, max_m, am, nmt0, iadmp)
Definition sms_rbe3.F:463
spmd_exch_rbe3_a_pon
subroutine spmd_exch_rbe3_a_pon(a, fr_m, iad_m, lcomm, isize)
Definition spmd_exch_rbe3_a_pon.F:35

◆ sms_rbe3t1()

subroutine sms_rbe3t1 ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
x,
a,
frbe3,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_m,
integer, dimension(*) fr_m,
integer, dimension(*) fr_mpon,
rsum,
double precision, dimension(*) rsum_pon,
integer r3size )

Definition at line 139 of file sms_rbe3.F.

143C-----------------------------------------------
144C I m p l i c i t T y p e s
145C-----------------------------------------------
146#include "implicit_f.inc"
147C-----------------------------------------------
148C C o m m o n B l o c k s
149C-----------------------------------------------
150#include "com01_c.inc"
151#include "com04_c.inc"
152#include "param_c.inc"
153#include "tabsiz_c.inc"
154C-----------------------------------------------
155C D u m m y A r g u m e n t s
156C-----------------------------------------------
157 INTEGER IRBE3(NRBE3L,*), LRBE3(*), WEIGHT(*), IAD_M(*), FR_M(*),
158 . FR_MPON(*),R3SIZE
159 my_real
160 . x(3,*), a(3,*), frbe3(*), skew(*), rsum(*)
161 double precision
162 . rsum_pon(*)
163C-----------------------------------------------
164C L o c a l V a r i a b l e s
165C-----------------------------------------------
166 INTEGER I, J, N, MAX_M,IROTG,JT(3,NRBE3),JR(3,NRBE3),IERR,NMT,
167 . IADA,IADMS,IADFN,IADAR,IADIN,IADFR,IADM0,IADI0,IADL,
168 . IPA,IPMS,IPFN,IPAR,IPIN,IPFR,NMP,IADLP,NS,NML,ICOM,
169 . IADLP1,IADM1,IADI1,NMT0,IADMP(SLRBE3/2),IML(SLRBE3/2),
170 . ISIZE
171C REAL
172C------------allacation will be removed to ini_ uniforming smp spmd in v11
173C my_real
174C . , DIMENSION(:), ALLOCATABLE :: RSUM
175C DOUBLE PRECISION
176C . , DIMENSION(:), ALLOCATABLE :: RSUM_PON
177C======================================================================|
178 nmt0 = slrbe3/2
179 CALL prerbe3(irbe3 ,max_m , irotg,jt ,jr )
180 icom = iad_m(nspmd+1)-iad_m(1)
181c IF (NSPMD>1)CALL SPMD_MAX_II(IROTG,IAD_M,ICOM)
182 IF (r3size>5)irotg = 1
183C
184 IF (nmt0>0) THEN
185 CALL prerbe3p(irbe3 ,lrbe3 ,iadmp ,iml , nmt )
186 iada=1
187 iadms=iada+3*nmt
188 iadfn=iadms+nmt
189 IF (irotg>0) THEN
190 iadar=iadfn+nmt
191 iadin=iadar+3*nmt
192 iadfr=iadin+nmt
193 ELSE
194 iadar=iadfn
195 iadin=iadar
196 iadfr=iadin
197 ENDIF
198 iadl=iadfr+nmt
199C
200C ALLOCATE(RSUM(IADL),STAT=IERR)
201 CALL zero1(rsum,iadl)
202 CALL sms_rbe3_1(
203 1 irbe3 ,lrbe3 ,x ,a ,frbe3 ,
204 2 skew ,weight,jt ,irotg ,max_m ,
205 3 rsum(iada),nmt0 ,iadmp )
206C
207 nmp = 6*nmt
208 ipa=1
209 ipms=ipa+3*nmp
210 ipfn=ipms+nmp
211 IF (irotg>0) THEN
212 ipar=ipfn+nmp
213 ipin=ipar+3*nmp
214 ipfr=ipin+nmp
215 ELSE
216 ipar=ipfn
217 ipin=ipar
218 ipfr=ipin
219 ENDIF
220 iadlp=ipfr+nmp
221C version spmd p/on
222C ALLOCATE(RSUM_PON(IADLP),STAT=IERR)
223C RSUM_PON=ZERO
224 CALL foat_to_6_float(1 ,nmt*3 ,rsum(iada) ,rsum_pon(ipa) )
225 IF (icom>0) THEN
226 isize=3
227 CALL spmd_exch_rbe3_a_pon(
228 . rsum_pon(ipa),fr_mpon,iad_m ,iad_m(nspmd+1),isize)
229 ENDIF
230C
231C Routine assemblage parith/ON
232C
233 CALL sms_rbe3_2(irbe3 ,lrbe3 ,a ,weight,rsum_pon(ipa),
234 2 nmt ,iml ,jt )
235C DEALLOCATE(RSUM_PON)
236C
237C DEALLOCATE(RSUM)
238 END IF ! IF (NMT>0)
239C---
240 RETURN
sms_rbe3_2
subroutine sms_rbe3_2(irbe3, lrbe3, a, weight, da, nmt, iml, jt)
Definition sms_rbe3.F:536

◆ sms_rbe3t2()

subroutine sms_rbe3t2 ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
x,
a,
frbe3,
skew,
r,
prec_sms3 )

Definition at line 252 of file sms_rbe3.F.

254C-----------------------------------------------
255C I m p l i c i t T y p e s
256C-----------------------------------------------
257#include "implicit_f.inc"
258C-----------------------------------------------
259C C o m m o n B l o c k s
260C-----------------------------------------------
261#include "com01_c.inc"
262#include "com04_c.inc"
263#include "param_c.inc"
264#include "tabsiz_c.inc"
265C-----------------------------------------------
266C D u m m y A r g u m e n t s
267C-----------------------------------------------
268 INTEGER IRBE3(NRBE3L,*),LRBE3(*)
269C REAL
270 my_real
271 . x(3,*), a(3,*), frbe3(*), skew(*), r(3,*), prec_sms3(3,*)
272C-----------------------------------------------
273C L o c a l V a r i a b l e s
274C-----------------------------------------------
275 INTEGER I, J, N, M, NS ,NML, IAD,JJ,IROT,IADS,MAX_M,IROTG,
276 . JT(3,NRBE3),JR(3,NRBE3),NM,NN,K,
277 . NMT,NMT0,IADMP(SLRBE3/2),IML(SLRBE3/2)
278C REAL
279 my_real
280 . as(3)
281 my_real,
282 . DIMENSION(:,:,:),ALLOCATABLE :: fdstnb ,mdstnb
283C======================================================================|
284 iads = slrbe3/2
285 CALL prerbe3(irbe3 ,max_m , irotg,jt ,jr )
286 ALLOCATE(fdstnb(3,6,max_m))
287 IF (irotg>0) ALLOCATE(mdstnb(3,6,max_m))
288C
289 nmt0 = slrbe3/2
290 IF (nmt0>0) THEN
291 CALL prerbe3p(irbe3 ,lrbe3 ,iadmp ,iml , nmt )
292 DO i=1,nmt
293 m = iml(i)
294 a(1,m)=r(1,m)*prec_sms3(1,m)
295 a(2,m)=r(2,m)*prec_sms3(2,m)
296 a(3,m)=r(3,m)*prec_sms3(3,m)
297 END DO
298 END IF
299C
300 DO n=1,nrbe3
301 iad = irbe3(1,n)
302 ns = irbe3(3,n)
303 IF (ns==0) cycle
304 nml = irbe3(5,n)
305 irot =min(irbe3(6,n),iroddl)
306 CALL rbe3cl(lrbe3(iad+1),lrbe3(iads+iad+1),ns ,x ,
307 . frbe3(6*iad+1),skew ,nml ,irot ,fdstnb ,
308 . mdstnb ,irbe3(2,n))
309 DO j = 1,3
310 as(j) = zero
311 ENDDO
312 DO i=1,nml
313 m = lrbe3(iad+i)
314 DO j = 1,3
315 DO k = 1,3
316 as(j) = as(j)+fdstnb(k,j,i)*a(k,m)
317 ENDDO
318 ENDDO
319 ENDDO
320 DO j = 1,3
321 a(j,ns) = as(j) *jt(j,n)
322 ENDDO
323 ENDDO
324C
325 DEALLOCATE(fdstnb)
326 IF (irotg>0) DEALLOCATE(mdstnb)
327C---
328 RETURN
min
#define min(a, b)
Definition macros.h:20