OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_int.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "task_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "timeri_c.inc"
#include "sms_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "scr18_c.inc"
#include "parit_c.inc"
#include "spmd_c.inc"
#include "param_c.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_tri7vox0 (x, bminmal, igap, nrtm, stf, tzinf, curv_max, gapmin, gapmax, gap_m, irect, gap, bgapsmx, drad, dgapload)
subroutine spmd_tri7vox (nsv, nsn, x, v, ms, bminmal, weight, stifn, nin, isendto, ircvfrom, iad_elem, fr_elem, nsnr, igap, gap_s, itab, kinet, ifq, inacti, nsnfiold, intth, ielec, areas, temp, num_imp, nodnx_sms, gap_s_l, ityp, irtlm, i24_time_s, i24_frfi, i24_pene_old, i24_stif_old, nbinflg, ilev, i24_icont_i, intfric, ipartfrics, itied, ivis2, if_adh)
subroutine spmd_tri18_151vox (nsv, nsn, x, v, ms, bminmal, weight, stifn, nin, isendto, ircvfrom, iad_elem, fr_elem, nsnr, igap, gap_s, itab, kinet, ifq, inacti, nsnfiold, intth, ielec, areas, temp, num_imp, nodnx_sms, gap_s_l, ityp, irtlm, i24_time_s, i24_frfi, i24_pene_old, i24_stif_old, nbinflg, ilev, i24_icont_i, ixs, multi_fvm, intfric, ipartfrics)
subroutine spmd_tri24vox (nsv, nsn, x, v, ms, bminmal, weight, stifn, nin, isendto, ircvfrom, iad_elem, fr_elem, nsnr, igap, gap_s, itab, kinet, ifq, inacti, nsnfiold, intth, ielec, areas, temp, num_imp, nodnx_sms, gap_s_l, ityp, i24_irtlm, i24_time_s, i24_frfi, i24_pene_old, i24_stif_old, nbinflg, ilev, i24_icont_i, xfic, vfic, iedge4, nsne, is2se, irtse, is2pt, isegpt, msfic, nrtse, is2id, ispt2, intfric, ipartfrics, t2main_sms, intnitsche, forneqs, t2fac_sms, istif_msdt, stifmsdt_s, ifsub_carea, intarean)
subroutine spmd_tri24gat (result, nsn, cand_n, i_stok, nin, igap, nsnr, multimp, ity, intth, ilev, iedge4, h3d_data, intfric, intnitsche, istif_msdt, ifsub_carea, nodadt_therm)
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)
subroutine spmd_tri10box (nsv, nsn, x, v, ms, bminmal, weight, stifn, nin, isendto, ircvfrom, iad_elem, fr_elem, nsnr, igap, gap_s, nsnfiold, nodnx_sms, itab, itied)
subroutine spmd_tri10gat (result, nsn, cand_n, i_stok, nin, igap, nsnr, multimp, ity, intth, h3d_data)
subroutine spmd_tri11vox0 (x, bminmal, igap, nrtm, stf, tzinf, irectm, gap, gap_m, gapmin, bgapsmx, drad, dgapload)
subroutine spmd_tri11vox (irects, nrts, x, v, ms, bminmal, weight, stifs, nin, isendto, ircvfrom, iad_elem, fr_elem, nrtsr, inacti, gap_s, penis, itab, igap, tzinf, nodnx_sms, gap_s_l, nsnfiold, iform, intth, ielec, areas, temp, nisub, addsubs, lisubs, intfric, ipartfrics, inflg_subs)
subroutine spmd_tri11gat (result, nrts, cand_s, i_stok, nin, inacti, nrtsr, multimp, igap, intth, nisub, intfric, nodadt_therm)
subroutine spmd_tri23vox0 (x, bminmal, igap, nrtm, stf, tzinf, curv_max, gapmin, gapmax, gap_m, irect, gap, bgapsmx, msr)
subroutine spmd_tri24vox0 (x, bminmal, nrtm, stf, marge, curv_max, gap_m, irect, gap, bgapsmx, pmax_gap, vmaxdt, dgapload)

Function/Subroutine Documentation

◆ spmd_tri10box()

subroutine spmd_tri10box ( integer, dimension(*) nsv,
integer nsn,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifn,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nsnr,
integer igap,
gap_s,
integer, dimension(*) nsnfiold,
integer, dimension(*) nodnx_sms,
integer, dimension(*) itab,
integer, intent(in) itied )

Definition at line 3545 of file spmd_int.F.

3549C-----------------------------------------------
3550C M o d u l e s
3551C-----------------------------------------------
3552 USE tri7box
3553 USE message_mod
3554 USE spmd_mod
3555C-----------------------------------------------
3556C I m p l i c i t T y p e s
3557C-----------------------------------------------
3558#include "implicit_f.inc"
3559C-----------------------------------------------
3560C C o m m o n B l o c k s
3561C-----------------------------------------------
3562#include "com01_c.inc"
3563#include "com04_c.inc"
3564#include "sms_c.inc"
3565#include "task_c.inc"
3566C-----------------------------------------------
3567C D u m m y A r g u m e n t s
3568C-----------------------------------------------
3569 INTEGER NIN, NSN, IGAP,
3570 . NSNFIOLD(*), NSV(*), WEIGHT(*), ITAB(*),
3571 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
3572 . IAD_ELEM(2,*), FR_ELEM(*), NODNX_SMS(*),NSNR
3573 INTEGER, INTENT(IN) :: ITIED
3574 my_real
3575 . x(3,*), v(3,*), ms(*), bminmal(*), stifn(*), gap_s(*)
3576
3577C-----------------------------------------------
3578C L o c a l V a r i a b l e s
3579C-----------------------------------------------
3580#ifdef MPI
3581 INTEGER MSGTYP, I, NOD, LOC_PROC, P, IDEB,
3582 . J, L, BUFSIZ, LEN, NB, IERROR1,
3583 . IERROR,REQ_SB(NSPMD),
3584 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
3585 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
3586 . INDEXI,ISINDEXI(NSPMD),INDEX(NUMNOD),NBOX(NSPMD),
3587 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4,
3588 . REQ_RD2(NSPMD), REQ_SD3(NSPMD),
3589 . RSIZ, ISIZ,RSHIFT,ISHIFT,LEN2,L2
3590
3591 DATA msgoff/6005/
3592 DATA msgoff2/6006/
3593 DATA msgoff3/6007/
3594 DATA msgoff4/6008/
3595
3596 my_real bminma(6,nspmd), ratio
3597 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
3598 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
3599
3600C-----------------------------------------------
3601C S o u r c e L i n e s
3602C-----------------------------------------------
3603C
3604C Old value backup of the NSN Frontieres
3605C
3606 !WRITE(6,*) __FILE__,__LINE__
3607 DO p = 1, nspmd
3608 nsnfiold(p) = nsnfi(nin)%P(p)
3609 END DO
3610C
3611 loc_proc = ispmd + 1
3612C
3613C minmax box for sorting from i10buce BMINMA
3614C
3615 IF(ircvfrom(nin,loc_proc)==0.AND.
3616 . isendto(nin,loc_proc)==0) RETURN
3617 bminma(1,loc_proc) = bminmal(1)
3618 bminma(2,loc_proc) = bminmal(2)
3619 bminma(3,loc_proc) = bminmal(3)
3620 bminma(4,loc_proc) = bminmal(4)
3621 bminma(5,loc_proc) = bminmal(5)
3622 bminma(6,loc_proc) = bminmal(6)
3623C
3624C Box sending
3625C
3626 IF(ircvfrom(nin,loc_proc)/=0) THEN
3627 DO p = 1, nspmd
3628 IF(isendto(nin,p)/=0) THEN
3629 IF(p/=loc_proc) THEN
3630 msgtyp = msgoff
3631 CALL spmd_isend(
3632 . bminma(1,loc_proc),6 ,it_spmd(p),msgtyp,
3633 . req_sb(p))
3634 ENDIF
3635 ENDIF
3636 ENDDO
3637 ENDIF
3638C
3639C Reception of Min-Max boxes
3640C
3641 IF(isendto(nin,loc_proc)/=0) THEN
3642 nbirecv=0
3643 DO p = 1, nspmd
3644 IF(ircvfrom(nin,p)/=0) THEN
3645 IF(loc_proc/=p) THEN
3646 msgtyp = msgoff
3647 nbirecv=nbirecv+1
3648 irindexi(nbirecv)=p
3649 CALL spmd_irecv(
3650 . bminma(1,p) ,6 ,it_spmd(p),msgtyp,
3651 . req_rb(nbirecv))
3652 ENDIF
3653 ENDIF
3654 ENDDO
3655 ENDIF
3656C
3657C sending of XREM
3658C
3659c general case
3660 rsiz = 8
3661 isiz = 2
3662
3663c IGAP > 0
3664 IF(igap>0) THEN
3665 rsiz = rsiz + 1
3666 ENDIF
3667
3668c IDTMINS = 2
3669 IF(idtmins == 2)THEN
3670 isiz = isiz + 2
3671c IDTMINS_INT /= 0
3672 ELSEIF(idtmins_int/=0)THEN
3673 isiz = isiz + 1
3674 END IF
3675
3676 ideb = 1
3677 IF(isendto(nin,loc_proc)/=0) THEN
3678 DO kk = 1, nbirecv
3679 CALL spmd_waitany(nbirecv,req_rb,indexi)
3680 p=irindexi(indexi)
3681C special treatment on d.d. to keep only internal nodes
3682 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
3683 nod = fr_elem(j)
3684C weight < 0 temporarily to keep only non-border nodes
3685 weight(nod) = weight(nod)*(-1)
3686 ENDDO
3687C
3688 l = ideb
3689 nbox(p) = 0
3690 nb = 0
3691 DO i=1,nsn
3692 nod = nsv(i)
3693 IF(weight(nod)==1)THEN
3694 IF(candf_si(nin)%P(i)/=0) THEN
3695 nb = nb + 1
3696 index(nb) = i
3697 !WRITE(6,*) "Force send of",ITAB(NOD),"TO",P-1
3698 ELSE
3699 IF(stifn(i)>zero)THEN
3700 IF(x(1,nod)<=bminma(1,p)) THEN
3701 IF(x(1,nod)>=bminma(4,p)) THEN
3702 IF(x(2,nod)<=bminma(2,p)) THEN
3703 IF(x(2,nod)>=bminma(5,p)) THEN
3704 IF(x(3,nod)<=bminma(3,p)) THEN
3705 IF(x(3,nod)>=bminma(6,p)) THEN
3706 nb = nb + 1
3707 index(nb) = i
3708 ENDIF
3709 ENDIF
3710 ENDIF
3711 ENDIF
3712 ENDIF
3713 ENDIF
3714 ENDIF
3715 ENDIF
3716 ENDIF
3717 ENDDO
3718 nbox(p) = nb
3719C
3720 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
3721 nod = fr_elem(j)
3722C reset of weight > 0
3723 weight(nod) = weight(nod)*(-1)
3724 ENDDO
3725C
3726C Envoi taille msg
3727C
3728 msgtyp = msgoff2
3729 CALL spmd_isend(nbox(p),1,it_spmd(p),msgtyp,
3730 . req_sd(p))
3731C
3732C Alloc buffer
3733C
3734 IF (nb>0) THEN
3735 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
3736 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
3737 IF(ierror/=0) THEN
3738 CALL ancmsg(msgid=20,anmode=aninfo)
3739 CALL arret(2)
3740 ENDIF
3741 l = 0
3742 l2 = 0
3743
3744c general case
3745 DO j = 1, nb
3746 i = index(j)
3747 nod = nsv(i)
3748 rbuf(p)%p(l+1) = x(1,nod)
3749 rbuf(p)%p(l+2) = x(2,nod)
3750 rbuf(p)%p(l+3) = x(3,nod)
3751 rbuf(p)%p(l+4) = v(1,nod)
3752 rbuf(p)%p(l+5) = v(2,nod)
3753 rbuf(p)%p(l+6) = v(3,nod)
3754 rbuf(p)%p(l+7) = ms(nod)
3755 rbuf(p)%p(l+8) = stifn(i)
3756 ibuf(p)%p(l2+1) = i
3757 ibuf(p)%p(l2+2) = itab(nod)
3758 l = l + rsiz
3759 l2 = l2 + isiz
3760 END DO
3761
3762c shift for real variables
3763 rshift = 8
3764c shift for integer variables
3765 ishift = 2
3766
3767c specific cases
3768c IGAP=1 or IGAP=2
3769 IF(igap>0)THEN
3770 l = 0
3771 rshift = rshift + 1
3772 DO j = 1, nb
3773 i = index(j)
3774 rbuf(p)%p(l+rshift)= gap_s(i)
3775 l = l + rsiz
3776 ENDDO
3777 ENDIF
3778
3779C -- IDTMINS==2
3780 IF(idtmins==2)THEN
3781 l2 = 0
3782 ishift = ishift + 1
3783 DO j = 1, nb
3784 i = index(j)
3785 nod = nsv(i)
3786 ibuf(p)%p(l2+ishift) = nodnx_sms(nod)
3787 ibuf(p)%p(l2+ishift+1)= nod
3788 l2 = l2 + isiz
3789 END DO
3790
3791C -- IDTMINS_INT /= 0
3792 ELSEIF(idtmins_int/=0)THEN
3793 l2 = 0
3794 ishift = ishift + 1
3795 DO j = 1, nb
3796 i = index(j)
3797 nod = nsv(i)
3798 ibuf(p)%p(l2+ishift)= nod
3799 l2 = l2 + isiz
3800 END DO
3801 ENDIF
3802
3803 msgtyp = msgoff3
3804 CALL spmd_isend(
3805 1 rbuf(p)%P(1),nb*rsiz,it_spmd(p),
3806 2 msgtyp,req_sd2(p))
3807
3808 msgtyp = msgoff4
3809 CALL spmd_isend(
3810 1 ibuf(p)%P(1),nb*isiz,it_spmd(p),msgtyp,
3811 2 req_sd3(p))
3812
3813 ENDIF
3814 ENDDO
3815 ENDIF
3816C
3817C reception of XREM data
3818C
3819 IF(ircvfrom(nin,loc_proc)/=0) THEN
3820 nsnr = 0
3821 l=0
3822 DO p = 1, nspmd
3823 nsnfi(nin)%P(p) = 0
3824 IF(isendto(nin,p)/=0) THEN
3825 IF(loc_proc/=p) THEN
3826 msgtyp = msgoff2
3827 CALL spmd_recv(nsnfi(nin)%P(p),1,it_spmd(p),
3828 . msgtyp)
3829 IF(nsnfi(nin)%P(p)>0) THEN
3830 l=l+1
3831 isindexi(l)=p
3832 nsnr = nsnr + nsnfi(nin)%P(p)
3833 ENDIF
3834 ENDIF
3835 ENDIF
3836 ENDDO
3837 nbirecv=l
3838C
3839C Allocate total size
3840C
3841 IF(nsnr>0) THEN
3842 ALLOCATE(xrem(rsiz,nsnr),stat=ierror)
3843
3844 ALLOCATE(irem(isiz,nsnr),stat=ierror1)
3845 ierror=ierror+ierror1
3846
3847 IF(ierror/=0) THEN
3848 CALL ancmsg(msgid=20,anmode=aninfo)
3849 CALL arret(2)
3850 ENDIF
3851
3852 ideb = 1
3853 DO l = 1, nbirecv
3854 p = isindexi(l)
3855 len = nsnfi(nin)%P(p)*rsiz
3856 msgtyp = msgoff3
3857
3858 CALL spmd_irecv(
3859 1 xrem(1,ideb),len,it_spmd(p),
3860 2 msgtyp,req_rd(l))
3861
3862 len2 = nsnfi(nin)%P(p)*isiz
3863 msgtyp = msgoff4
3864 CALL spmd_irecv(
3865 1 irem(1,ideb),len2,it_spmd(p),
3866 2 msgtyp,req_rd2(l))
3867
3868 ideb = ideb + nsnfi(nin)%P(p)
3869
3870 ENDDO
3871 DO l = 1, nbirecv
3872 CALL spmd_waitany(nbirecv,req_rd,indexi)
3873 CALL spmd_waitany(nbirecv,req_rd2,indexi)
3874 ENDDO
3875
3876 ENDIF
3877 ENDIF
3878C
3879 IF(ircvfrom(nin,loc_proc)/=0) THEN
3880 DO p = 1, nspmd
3881 IF(isendto(nin,p)/=0) THEN
3882 IF(p/=loc_proc) THEN
3883 CALL spmd_wait(req_sb(p))
3884 ENDIF
3885 ENDIF
3886 ENDDO
3887 ENDIF
3888C
3889 IF(isendto(nin,loc_proc)/=0) THEN
3890 DO p = 1, nspmd
3891 IF(ircvfrom(nin,p)/=0) THEN
3892 IF(p/=loc_proc) THEN
3893 CALL spmd_wait(req_sd(p))
3894 IF(nbox(p)/=0) THEN
3895 CALL spmd_wait(req_sd2(p))
3896 DEALLOCATE(rbuf(p)%p)
3897 CALL spmd_wait(req_sd3(p))
3898 DEALLOCATE(ibuf(p)%p)
3899 END IF
3900 ENDIF
3901 ENDIF
3902 ENDDO
3903 ENDIF
3904C
3905#endif
3906 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
message_mod
Definition message_mod.F:1257
tri7box::candf_si
type(int_pointer), dimension(:), allocatable candf_si
Definition tri7box.F:560
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
tri7box::irem
integer, dimension(:,:), allocatable irem
Definition tri7box.F:339
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
arret
subroutine arret(nn)
Definition arret.F:86

◆ spmd_tri10gat()

subroutine spmd_tri10gat ( integer result,
integer nsn,
integer, dimension(*) cand_n,
integer i_stok,
integer nin,
integer igap,
integer nsnr,
integer multimp,
integer ity,
integer intth,
type(h3d_database) h3d_data )

Definition at line 3923 of file spmd_int.F.

3925C-----------------------------------------------
3926C M o d u l e s
3927C-----------------------------------------------
3928 USE tri7box
3929 USE message_mod
3930 USE h3d_mod
3931 USE spmd_mod
3932C-----------------------------------------------
3933C I m p l i c i t T y p e s
3934C-----------------------------------------------
3935#include "implicit_f.inc"
3936C-----------------------------------------------
3937C C o m m o n B l o c k s
3938C-----------------------------------------------
3939#include "com01_c.inc"
3940#include "task_c.inc"
3941#include "scr14_c.inc"
3942#include "scr16_c.inc"
3943#include "scr18_c.inc"
3944#include "parit_c.inc"
3945#include "spmd_c.inc"
3946#include "sms_c.inc"
3947C-----------------------------------------------
3948C D u m m y A r g u m e n t s
3949C-----------------------------------------------
3950 INTEGER RESULT, NIN, NSN, I_STOK, IGAP, NSNR, MULTIMP, ITY,
3951 . CAND_N(*),INTTH
3952 TYPE(H3D_DATABASE) :: H3D_DATA
3953C-----------------------------------------------
3954C L o c a l V a r i a b l e s
3955C-----------------------------------------------
3956#ifdef MPI
3957 INTEGER OLDNSNR,NODFI,NNP,LSKYFI,
3958 . NOD, LOC_PROC, I, N, NN, P, IDEB, J, K,
3959 . IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,IERROR6,IERROR7,
3960 . IERROR8,IERROR9,IERROR10,IERROR11,IERROR12,IERROR13,
3961 . INDEX(NSNR),NN2,RSHIFT,ISHIFT
3962
3963 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX
3964C-----------------------------------------------
3965C S o u r c e L i n e s
3966C-----------------------------------------------
3967 loc_proc = ispmd + 1
3968C
3969C
3970 nodfi = 0
3971 lskyfi= 0
3972 IF(result==0) THEN
3973C
3974C identification of candidates
3975C
3976 nodfi = 0
3977 DO i = 1, i_stok
3978 n = cand_n(i)
3979 nn = n-nsn
3980 IF(nn>0)THEN
3981 IF(irem(1,nn)>0)THEN
3982 nodfi = nodfi + 1
3983 irem(1,nn) = -irem(1,nn)
3984 ENDIF
3985 ENDIF
3986 ENDDO
3987C
3988C allocation of interface boundary arrays
3989C
3990 ierror1 = 0
3991 ierror2 = 0
3992 ierror3 = 0
3993 ierror4 = 0
3994 ierror5 = 0
3995 ierror6 = 0
3996 ierror7 = 0
3997 ierror8 = 0
3998 ierror9 = 0
3999 ierror10 = 0
4000 ierror11 = 0
4001 ierror12 = 0
4002 ierror13 = 0
4003
4004 IF(ASSOCIATED(nsvfi(nin)%P)) DEALLOCATE(nsvfi(nin)%P)
4005 ALLOCATE(nsvfi(nin)%P(nodfi),stat=ierror1)
4006 IF(ASSOCIATED(xfi(nin)%P)) DEALLOCATE(xfi(nin)%P)
4007 ALLOCATE(xfi(nin)%P(3,nodfi),stat=ierror2)
4008 IF(ASSOCIATED(vfi(nin)%P)) DEALLOCATE(vfi(nin)%P)
4009 ALLOCATE(vfi(nin)%P(3,nodfi),stat=ierror3)
4010 IF(ASSOCIATED(msfi(nin)%P)) DEALLOCATE(msfi(nin)%P)
4011 ALLOCATE(msfi(nin)%P(nodfi),stat=ierror4)
4012 IF(ASSOCIATED(stifi(nin)%P)) DEALLOCATE(stifi(nin)%P)
4013 ALLOCATE(stifi(nin)%P(nodfi),stat=ierror5)
4014 IF(ASSOCIATED(itafi(nin)%P)) DEALLOCATE(itafi(nin)%P)
4015 ALLOCATE(itafi(nin)%P(nodfi),stat=ierror6)
4016 IF(idtmins == 2) THEN
4017 IF(ASSOCIATED(nodnxfi(nin)%P)) DEALLOCATE(nodnxfi(nin)%P)
4018 ALLOCATE(nodnxfi(nin)%P(nodfi),stat=ierror7)
4019 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
4020 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror8)
4021 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
4022 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror9)
4023 ELSEIF(idtmins_int /= 0) THEN
4024 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
4025 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror10)
4026 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
4027 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror11)
4028 ENDIF
4029 IF(igap/=0) THEN
4030 IF(ASSOCIATED(gapfi(nin)%P)) DEALLOCATE(gapfi(nin)%P)
4031 ALLOCATE(gapfi(nin)%P(nodfi),stat=ierror12)
4032 IF(igap==3) THEN
4033 IF(ASSOCIATED(gap_lfi(nin)%P)) DEALLOCATE(gap_lfi(nin)%P)
4034 ALLOCATE(gap_lfi(nin)%P(nodfi),stat=ierror12)
4035 ENDIF
4036 ENDIF
4037C
4038 IF((ierror1+ierror2+ierror3+ierror4+ierror5+
4039 + ierror6+ierror7+ierror8 + ierror9 + ierror10 +
4040 + ierror11+ierror12)>0) THEN
4041 CALL ancmsg(msgid=20,anmode=aninfo)
4042 CALL arret(2)
4043 ENDIF
4044C
4045C compaction of candidates
4046C
4047 ideb = 0
4048 nn2 = 0
4049
4050 DO p = 1, nspmd
4051 nn = 0
4052 oldnsnr = nsnfi(nin)%P(p)
4053
4054 IF(oldnsnr/=0) THEN
4055
4056 ALLOCATE(iaux(oldnsnr),stat=ierror13)
4057 IF(ierror13/=0) THEN
4058 CALL ancmsg(msgid=20,anmode=aninfo)
4059 CALL arret(2)
4060 ENDIF
4061
4062 nnp = nn2
4063
4064 DO i = 1, oldnsnr
4065 IF(irem(1,i+ideb)<0) THEN
4066 nn = nn + 1
4067 iaux(nn) = i
4068 ENDIF
4069 ENDDO
4070
4071c general case
4072#include "vectorize.inc"
4073 DO j = 1, nn
4074 i = iaux(j)
4075 index(i+ideb) = nn2+j
4076 xfi(nin)%P(1,nn2+j) = xrem(1,i+ideb)
4077 xfi(nin)%P(2,nn2+j) = xrem(2,i+ideb)
4078 xfi(nin)%P(3,nn2+j) = xrem(3,i+ideb)
4079 vfi(nin)%P(1,nn2+j) = xrem(4,i+ideb)
4080 vfi(nin)%P(2,nn2+j) = xrem(5,i+ideb)
4081 vfi(nin)%P(3,nn2+j) = xrem(6,i+ideb)
4082 msfi(nin)%P(nn2+j) = xrem(7,i+ideb)
4083 stifi(nin)%P(nn2+j) = xrem(8,i+ideb)
4084 nsvfi(nin)%P(nn2+j) = -irem(1,i+ideb)
4085 itafi(nin)%P(nn2+j) = irem(2,i+ideb)
4086 ENDDO
4087
4088 rshift = 8
4089 ishift = 2
4090
4091c IGAP=1 or IGAP=2
4092 IF(igap>0)THEN
4093 rshift = rshift + 1
4094#include "vectorize.inc"
4095 DO j = 1, nn
4096 i = iaux(j)
4097 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
4098 ENDDO
4099 ENDIF
4100
4101C -- IDTMINS==2
4102 IF(idtmins==2)THEN
4103 ishift = ishift + 1
4104#include "vectorize.inc"
4105 DO j = 1, nn
4106 i = iaux(j)
4107 nodnxfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
4108 nodamsfi(nin)%P(nn2+j) = irem(ishift+1,i+ideb)
4109 procamsfi(nin)%P(nn2+j) = p
4110 ENDDO
4111
4112C -- IDTMINS_INT /= 0
4113 ELSEIF(idtmins_int/=0)THEN
4114 ishift = ishift + 1
4115#include "vectorize.inc"
4116 DO j = 1, nn
4117 i = iaux(j)
4118 nodamsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
4119 procamsfi(nin)%P(nn2+j) = p
4120 ENDDO
4121 ENDIF
4122
4123 nn2 = nn2 + nn
4124 ideb = ideb + oldnsnr
4125 nsnfi(nin)%P(p) = nn2-nnp
4126
4127 DEALLOCATE(iaux)
4128
4129 ENDIF !IF(OLDNSNR/=0)
4130
4131 ENDDO ! fin do NSPMD
4132
4133 lskyfi = nn2*multimax
4134C NSNR New useful for inactive
4135 nsnr = nn2
4136 ENDIF
4137C
4138C deallocation of XREM
4139C
4140 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
4141 IF(ALLOCATED(irem)) DEALLOCATE(irem)
4142C
4143 ierror1=0
4144 ierror2=0
4145 ierror3=0
4146 ierror4=0
4147C
4148C Allocation Parith/OFF
4149C
4150 IF(iparit==0) THEN
4151 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
4152 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
4153 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
4154 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
4155C Init a 0
4156 DO i = 1, nodfi*nthread
4157 afi(nin)%P(1,i) = zero
4158 afi(nin)%P(2,i) = zero
4159 afi(nin)%P(3,i) = zero
4160 stnfi(nin)%P(i) = zero
4161 ENDDO
4162C
4163 IF(kdtint/=0)THEN
4164 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
4165 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
4166C Init a 0
4167 DO i = 1, nodfi*nthread
4168 vscfi(nin)%P(i) = zero
4169 ENDDO
4170 ENDIF
4171C
4172 nlskyfi(nin) = nodfi
4173C
4174 ELSE
4175C
4176C Allocation Parith/ON
4177C
4178 IF(ASSOCIATED(fskyfi(nin)%P)) DEALLOCATE(fskyfi(nin)%P)
4179 IF(ASSOCIATED(iskyfi(nin)%P)) DEALLOCATE(iskyfi(nin)%P)
4180 nlskyfi(nin) = lskyfi
4181 IF(lskyfi>0) THEN
4182 ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror1)
4183 IF(kdtint==0) THEN
4184 ALLOCATE(fskyfi(nin)%P(4,lskyfi),stat=ierror2)
4185 ELSE
4186 ALLOCATE(fskyfi(nin)%P(5,lskyfi),stat=ierror2)
4187 ENDIF
4188 ENDIF
4189 ENDIF
4190C
4191 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
4192 CALL ancmsg(msgid=20,anmode=aninfo)
4193 CALL arret(2)
4194 ENDIF
4195C
4196C Output Pressure conditional allowances
4197C
4198 IF(anim_v(12)+outp_v(12)+h3d_data%N_VECT_PCONT >0)THEN
4199 IF(ASSOCIATED(fnconti(nin)%P)) DEALLOCATE(fnconti(nin)%P)
4200 IF(ASSOCIATED(ftconti(nin)%P)) DEALLOCATE(ftconti(nin)%P)
4201 ALLOCATE(fnconti(nin)%P(3,nodfi),stat=ierror1)
4202 ALLOCATE(ftconti(nin)%P(3,nodfi),stat=ierror2)
4203 IF(ierror1+ierror2/=0) THEN
4204 CALL ancmsg(msgid=20,anmode=aninfo)
4205 CALL arret(2)
4206 ELSE
4207 DO j = 1, nodfi
4208 fnconti(nin)%P(1,j)=zero
4209 fnconti(nin)%P(2,j)=zero
4210 fnconti(nin)%P(3,j)=zero
4211 ftconti(nin)%P(1,j)=zero
4212 ftconti(nin)%P(2,j)=zero
4213 ftconti(nin)%P(3,j)=zero
4214 END DO
4215 END IF
4216 END IF
4217C
4218C renumbering of candidates
4219C
4220 DO i = 1, i_stok
4221 n = cand_n(i)
4222 nn = n-nsn
4223 IF(nn>0)THEN
4224 cand_n(i) = index(nn)+nsn
4225 ENDIF
4226 ENDDO
4227C
4228#endif
4229 RETURN
h3d_mod
Definition h3d_mod.F:311
tri7box::vfi
type(real_pointer2), dimension(:), allocatable vfi
Definition tri7box.F:459
tri7box::fnconti
type(real_pointer2), dimension(:), allocatable fnconti
Definition tri7box.F:510
tri7box::stifi
type(real_pointer), dimension(:), allocatable stifi
Definition tri7box.F:449
tri7box::gap_lfi
type(real_pointer), dimension(:), allocatable gap_lfi
Definition tri7box.F:449
tri7box::stnfi
type(real_pointer), dimension(:), allocatable stnfi
Definition tri7box.F:449
tri7box::afi
type(real_pointer2), dimension(:), allocatable afi
Definition tri7box.F:459
tri7box::nodamsfi
type(int_pointer), dimension(:), allocatable nodamsfi
Definition tri7box.F:440
tri7box::fskyfi
type(real_pointer2), dimension(:), allocatable fskyfi
Definition tri7box.F:459
tri7box::gapfi
type(real_pointer), dimension(:), allocatable gapfi
Definition tri7box.F:449
tri7box::nodnxfi
type(int_pointer), dimension(:), allocatable nodnxfi
Definition tri7box.F:440
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::iskyfi
type(int_pointer), dimension(:), allocatable iskyfi
Definition tri7box.F:480
tri7box::msfi
type(real_pointer), dimension(:), allocatable msfi
Definition tri7box.F:449
tri7box::vscfi
type(real_pointer), dimension(:), allocatable vscfi
Definition tri7box.F:449
tri7box::xfi
type(real_pointer2), dimension(:), allocatable xfi
Definition tri7box.F:459
tri7box::nlskyfi
integer, dimension(:), allocatable nlskyfi
Definition tri7box.F:512
tri7box::ftconti
type(real_pointer2), dimension(:), allocatable ftconti
Definition tri7box.F:510
tri7box::procamsfi
type(int_pointer), dimension(:), allocatable procamsfi
Definition tri7box.F:440
tri7box::itafi
type(int_pointer), dimension(:), allocatable itafi
Definition tri7box.F:440

◆ spmd_tri11gat()

subroutine spmd_tri11gat ( integer result,
integer nrts,
integer, dimension(*) cand_s,
integer i_stok,
integer nin,
integer inacti,
integer nrtsr,
integer multimp,
integer igap,
integer intth,
integer nisub,
integer intfric,
integer, intent(in) nodadt_therm )

Definition at line 4917 of file spmd_int.F.

4920C-----------------------------------------------
4921C M o d u l e s
4922C-----------------------------------------------
4923 USE tri7box
4924 USE message_mod
4925 USE spmd_mod
4926C-----------------------------------------------
4927C I m p l i c i t T y p e s
4928C-----------------------------------------------
4929#include "implicit_f.inc"
4930C-----------------------------------------------
4931C C o m m o n B l o c k s
4932C-----------------------------------------------
4933#include "com01_c.inc"
4934#include "task_c.inc"
4935#include "scr18_c.inc"
4936#include "parit_c.inc"
4937#include "spmd_c.inc"
4938#include "sms_c.inc"
4939C-----------------------------------------------
4940C D u m m y A r g u m e n t s
4941C-----------------------------------------------
4942 INTEGER RESULT, NIN, NRTS, I_STOK, INACTI, NRTSR, MULTIMP, IGAP,
4943 . CAND_S(*),INTTH,NISUB,INTFRIC
4944 INTEGER ,INTENT(IN) :: NODADT_THERM
4945C-----------------------------------------------
4946C L o c a l V a r i a b l e s
4947C-----------------------------------------------
4948#ifdef MPI
4949 INTEGER OLDNRTSR,SEGFI,NODFI,NNP,LSKYFI,
4950 . NOD, LOC_PROC, I, N, NN, P, IDEB, N1, N2,
4951 . IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,IERROR6,IERROR7,
4952 . IERROR8,IERROR9,IERROR10,IERROR11,IERROR12,IERROR13,IERROR14,
4953 . IERROR15,IERROR16,IERROR17,INDEX(NRTSR), NN2, RSHIFT, ISHIFT, J, K, L,IDEB_SUBINT,
4954 . LL
4955
4956 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX
4957C-----------------------------------------------
4958C S o u r c e L i n e s
4959C-----------------------------------------------
4960 loc_proc = ispmd + 1
4961C
4962C
4963 segfi = 0
4964 lskyfi= 0
4965 nodfi = 0
4966 IF(result==0) THEN
4967C
4968C identification of candidates
4969C
4970 segfi = 0
4971 DO i = 1, i_stok
4972 n = cand_s(i)
4973 nn = n-nrts
4974 IF(nn>0)THEN
4975 IF(irem(1,nn)>0)THEN
4976 segfi = segfi + 1
4977 irem(1,nn) = -irem(1,nn)
4978 ENDIF
4979 ENDIF
4980 ENDDO
4981C not optimal because duplicate nodes potentially
4982 nodfi = 2*segfi
4983C
4984C allocation of interface boundary arrays
4985C
4986 ierror1 = 0
4987 ierror2 = 0
4988 ierror3 = 0
4989 ierror4 = 0
4990 ierror5 = 0
4991 ierror6 = 0
4992 ierror7 = 0
4993 ierror8 = 0
4994 ierror9 = 0
4995 ierror10 = 0
4996 ierror11 = 0
4997 ierror12 = 0
4998 ierror13 = 0
4999 ierror14 = 0
5000 ierror15 = 0
5001 ierror16 = 0
5002 ierror17 = 0
5003C
5004 IF(ASSOCIATED(nsvfi(nin)%P)) DEALLOCATE(nsvfi(nin)%P)
5005 ALLOCATE(nsvfi(nin)%P(segfi),stat=ierror1)
5006 IF(ASSOCIATED(xfi(nin)%P)) DEALLOCATE(xfi(nin)%P)
5007 ALLOCATE(xfi(nin)%P(3,nodfi),stat=ierror2)
5008 IF(ASSOCIATED(vfi(nin)%P)) DEALLOCATE(vfi(nin)%P)
5009 ALLOCATE(vfi(nin)%P(3,nodfi),stat=ierror3)
5010 IF(ASSOCIATED(msfi(nin)%P)) DEALLOCATE(msfi(nin)%P)
5011 ALLOCATE(msfi(nin)%P(nodfi),stat=ierror4)
5012 IF(ASSOCIATED(stifi(nin)%P)) DEALLOCATE(stifi(nin)%P)
5013 ALLOCATE(stifi(nin)%P(segfi),stat=ierror5)
5014 IF(ASSOCIATED(itafi(nin)%P)) DEALLOCATE(itafi(nin)%P)
5015 ALLOCATE(itafi(nin)%P(nodfi),stat=ierror6)
5016 IF(idtmins == 2) THEN
5017 IF(ASSOCIATED(nodnxfi(nin)%P)) DEALLOCATE(nodnxfi(nin)%P)
5018 ALLOCATE(nodnxfi(nin)%P(nodfi),stat=ierror7)
5019 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
5020 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror8)
5021 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
5022 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror9)
5023 ELSEIF(idtmins_int /= 0) THEN
5024 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
5025 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror8)
5026 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
5027 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror9)
5028 ENDIF
5029 IF(igap/=0) THEN
5030 IF(ASSOCIATED(gapfi(nin)%P)) DEALLOCATE(gapfi(nin)%P)
5031 ALLOCATE(gapfi(nin)%P(segfi),stat=ierror10)
5032 END IF
5033 IF(igap==3) THEN
5034 IF(ASSOCIATED(gap_lfi(nin)%P)) DEALLOCATE(gap_lfi(nin)%P)
5035 ALLOCATE(gap_lfi(nin)%P(nodfi),stat=ierror7)
5036 ENDIF
5037 IF(inacti==5.OR.inacti==6) THEN
5038 IF(ASSOCIATED(penfi(nin)%P)) DEALLOCATE(penfi(nin)%P)
5039 ALLOCATE(penfi(nin)%P(2,segfi),stat=ierror11)
5040 END IF
5041
5042 IF(intth > 0 ) THEN
5043 IF(ASSOCIATED(tempfi(nin)%P)) DEALLOCATE(tempfi(nin)%P)
5044 ALLOCATE(tempfi(nin)%P(2*nodfi),stat=ierror12)
5045 IF(ASSOCIATED(matsfi(nin)%P)) DEALLOCATE(matsfi(nin)%P)
5046 ALLOCATE(matsfi(nin)%P(segfi),stat=ierror13)
5047 IF(ASSOCIATED(areasfi(nin)%P)) DEALLOCATE(areasfi(nin)%P)
5048 ALLOCATE(areasfi(nin)%P(segfi),stat=ierror14)
5049 ENDIF
5050
5051 IF(intfric > 0 ) THEN
5052 IF(ASSOCIATED(ipartfricsfi(nin)%P)) DEALLOCATE(ipartfricsfi(nin)%P)
5053 ALLOCATE(ipartfricsfi(nin)%P(segfi),stat=ierror17)
5054 ENDIF
5055
5056 IF(nisub > 0 ) THEN
5057 IF(ASSOCIATED(addsubsfi(nin)%P)) DEALLOCATE(addsubsfi(nin)%P)
5058 ALLOCATE(addsubsfi(nin)%P(segfi),stat=ierror15)
5059 IF(ASSOCIATED(lisubsfi(nin)%P)) DEALLOCATE(lisubsfi(nin)%P)
5060 ALLOCATE(lisubsfi(nin)%P(nisub*segfi),stat=ierror16)
5061 IF(ASSOCIATED(inflg_subsfi(nin)%P)) DEALLOCATE(inflg_subsfi(nin)%P)
5062 ALLOCATE(inflg_subsfi(nin)%P(nisub*segfi),stat=ierror16)
5063 ENDIF
5064C
5065 IF(ierror1+ierror2+ierror3+ierror4+ierror5+
5066 + ierror6+ierror7+ierror8+ierror9+ierror10+
5067 + ierror11+ierror12+ierror13+ierror14+ierror15+
5068 + ierror16+ierror17/=0) THEN
5069 CALL ancmsg(msgid=20,anmode=aninfo)
5070 CALL arret(2)
5071 ENDIF
5072C
5073C compaction of candidates
5074C
5075C
5076 ideb = 0
5077 nn2 = 0
5078 ideb_subint = 0
5079
5080 DO p = 1, nspmd
5081 nn = 0
5082 oldnrtsr = nsnfi(nin)%P(p)
5083
5084 IF(oldnrtsr/=0) THEN
5085
5086 ALLOCATE(iaux(oldnrtsr),stat=ierror12)
5087 IF(ierror12/=0) THEN
5088 CALL ancmsg(msgid=20,anmode=aninfo)
5089 CALL arret(2)
5090 ENDIF
5091 nnp = nn2
5092
5093 DO i = 1, oldnrtsr
5094 IF(irem(1,i+ideb)<0) THEN
5095 nn = nn + 1
5096 iaux(nn) = i
5097 ENDIF
5098 ENDDO
5099
5100c general case
5101#include "vectorize.inc"
5102 DO j = 1, nn
5103 i = iaux(j)
5104 index(i+ideb) = nn2+j
5105 n1 = 2*((nn2+j)-1)+1
5106 n2 = 2*(nn2+j)
5107 xfi(nin)%P(1,n1) = xrem(1,i+ideb)
5108 xfi(nin)%P(2,n1) = xrem(2,i+ideb)
5109 xfi(nin)%P(3,n1) = xrem(3,i+ideb)
5110 vfi(nin)%P(1,n1) = xrem(4,i+ideb)
5111 vfi(nin)%P(2,n1) = xrem(5,i+ideb)
5112 vfi(nin)%P(3,n1) = xrem(6,i+ideb)
5113 msfi(nin)%P(n1) = xrem(7,i+ideb)
5114 xfi(nin)%P(1,n2) = xrem(8,i+ideb)
5115 xfi(nin)%P(2,n2) = xrem(9,i+ideb)
5116 xfi(nin)%P(3,n2) = xrem(10,i+ideb)
5117 vfi(nin)%P(1,n2) = xrem(11,i+ideb)
5118 vfi(nin)%P(2,n2) = xrem(12,i+ideb)
5119 vfi(nin)%P(3,n2) = xrem(13,i+ideb)
5120 msfi(nin)%P(n2) = xrem(14,i+ideb)
5121 stifi(nin)%P(nn2+j) = xrem(15,i+ideb)
5122 nsvfi(nin)%P(nn2+j) = -irem(1,i+ideb)
5123 itafi(nin)%P(n1) = irem(2,i+ideb)
5124 itafi(nin)%P(n2) = irem(3,i+ideb)
5125 END DO
5126
5127 rshift = 16
5128 ishift = 4
5129
5130c IGAP=1 or IGAP=2
5131 IF(igap==1 .OR. igap==2)THEN
5132#include "vectorize.inc"
5133 DO j = 1, nn
5134 i = iaux(j)
5135 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
5136 ENDDO
5137 rshift = rshift + 1
5138c IGAP=3
5139 ELSEIF(igap==3)THEN
5140#include "vectorize.inc"
5141 DO j = 1, nn
5142 i = iaux(j)
5143 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
5144 gap_lfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
5145 ENDDO
5146 rshift = rshift + 2
5147 ENDIF
5148
5149C thermic
5150 IF(intth>0)THEN
5151#include "vectorize.inc"
5152 DO j = 1, nn
5153 i = iaux(j)
5154 n1 = 2*((nn2+j)-1)+1
5155 n2 = 2*(nn2+j)
5156 tempfi(nin)%P(n1) = xrem(rshift,i+ideb)
5157 tempfi(nin)%P(n2) = xrem(rshift+1,i+ideb)
5158 areasfi(nin)%P(nn2+j) = xrem(rshift+2,i+ideb)
5159 matsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
5160 ENDDO
5161 rshift = rshift + 3
5162 ishift = ishift + 1
5163 ENDIF
5164C Friction model
5165 IF(intfric>0)THEN
5166#include "vectorize.inc"
5167 DO j = 1, nn
5168 i = iaux(j)
5169 ipartfricsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
5170 ENDDO
5171 ishift = ishift + 1
5172 ENDIF
5173
5174c INACTI = 5 or 6
5175 IF(inacti==5.OR.inacti==6)THEN
5176#include "vectorize.inc"
5177 DO j = 1, nn
5178 i = iaux(j)
5179 penfi(nin)%P(1,nn2+j) = xrem(rshift,i+ideb)
5180 penfi(nin)%P(2,nn2+j) = xrem(rshift+1,i+ideb)
5181 ENDDO
5182 rshift = rshift + 2
5183 ENDIF
5184
5185
5186
5187C -- IDTMINS==2
5188 IF(idtmins==2)THEN
5189#include "vectorize.inc"
5190 DO j = 1, nn
5191 i = iaux(j)
5192 n1 = 2*((nn2+j)-1)+1
5193 n2 = 2*(nn2+j)
5194 nodnxfi(nin)%P(n1) = irem(ishift,i+ideb)
5195 nodamsfi(nin)%P(n1) = irem(ishift+1,i+ideb)
5196 procamsfi(nin)%P(n1) = p
5197 nodnxfi(nin)%P(n2) = irem(ishift+2,i+ideb)
5198 nodamsfi(nin)%P(n2) = irem(ishift+3,i+ideb)
5199 procamsfi(nin)%P(n2) = p
5200 ENDDO
5201 ishift = ishift + 4
5202
5203C -- IDTMINS_INT /= 0
5204 ELSEIF(idtmins_int/=0)THEN
5205
5206#include "vectorize.inc"
5207 DO j = 1, nn
5208 i = iaux(j)
5209 n1 = 2*((nn2+j)-1)+1
5210 n2 = 2*(nn2+j)
5211 nodamsfi(nin)%P(n1) = irem(ishift,i+ideb)
5212 procamsfi(nin)%P(n1) = p
5213 nodamsfi(nin)%P(n2) = irem(ishift+1,i+ideb)
5214 procamsfi(nin)%P(n2) = p
5215 ENDDO
5216 ishift = ishift + 2
5217 ENDIF
5218
5219C -- SUBINTERFACES
5220 IF ((nisub>0).AND.(nn>0)) THEN
5221C-- First line
5222 i = iaux(1)
5223 addsubsfi(nin)%P(nn2+1) = ideb_subint + 1
5224 ll = 0
5225 DO k = 1,irem(ishift,i+ideb)
5226 ll = ll + 1
5227 lisubsfi(nin)%P(ideb_subint+k) = irem(ishift+ll,i+ideb)
5228 ll = ll + 1
5229 inflg_subsfi(nin)%P(ideb_subint+k) = irem(ishift+ll,i+ideb)
5230 END DO
5231C
5232#include "vectorize.inc"
5233 DO j = 2, nn
5234 i = iaux(j)
5235 addsubsfi(nin)%P(nn2+j) = addsubsfi(nin)%P(nn2+j-1) + irem(ishift,i+ideb)
5236 ll = 0
5237 DO k = 1,irem(ishift,i+ideb)
5238 ll = ll + 1
5239 lisubsfi(nin)%P(addsubsfi(nin)%P(nn2+j)+k-1) = irem(ishift+ll,i+ideb)
5240 ll = ll + 1
5241 inflg_subsfi(nin)%P(addsubsfi(nin)%P(nn2+j)+k-1) = irem(ishift+ll,i+ideb)
5242 END DO
5243 ENDDO
5244C
5245 ideb_subint = addsubsfi(nin)%P(nn2+nn)
5246 ishift = ishift + 1 + 2*nisub
5247 ENDIF
5248C
5249 nn2 = nn2 + nn
5250 ideb = ideb + oldnrtsr
5251 nsnfi(nin)%P(p) = nn2-nnp
5252C
5253 DEALLOCATE(iaux)
5254
5255 ENDIF !IF(OLDNRTSR/=0)
5256
5257 ENDDO ! end do NSPMD
5258
5259C factor 2 because 2 nodes by segment => taken into account at the level
5260C of the 1st allocated dimension
5261 lskyfi = nn2*multimax
5262 nrtsr = nn2
5263 ENDIF
5264C
5265C deallocation of XREM IREM
5266C
5267 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
5268 IF(ALLOCATED(irem)) DEALLOCATE(irem)
5269C
5270 ierror1=0
5271 ierror2=0
5272 ierror3=0
5273 ierror4=0
5274C
5275 IF(intth == 0 ) THEN
5276C
5277C Allocation Parith/OFF
5278C
5279 IF(iparit==0) THEN
5280 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
5281 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
5282 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
5283 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
5284C Init a 0
5285 DO i = 1, nodfi*nthread
5286 afi(nin)%P(1,i) = zero
5287 afi(nin)%P(2,i) = zero
5288 afi(nin)%P(3,i) = zero
5289 stnfi(nin)%P(i) = zero
5290 ENDDO
5291C
5292 IF(kdtint/=0)THEN
5293 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
5294 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
5295C Init a 0
5296 DO i = 1, nodfi*nthread
5297 vscfi(nin)%P(i) = zero
5298 ENDDO
5299 ENDIF
5300C
5301 nlskyfi(nin) = nodfi
5302C
5303 ELSE
5304C
5305C Allocation Parith/ON Dans UPGRADE_REM_2RY
5306
5307 ENDIF
5308 ELSE ! INTTH /= 0
5309C
5310C Allocation Parith/OFF
5311C
5312 IF(iparit==0) THEN
5313 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
5314 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
5315 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
5316 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
5317 IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror3)
5318C
5319 IF(nodadt_therm ==1) THEN
5320 IF(ASSOCIATED(condnfi(nin)%P)) DEALLOCATE(condnfi(nin)%P)
5321 IF(nodfi>0) ALLOCATE(condnfi(nin)%P(nodfi*nthread),stat=ierror4)
5322 ENDIF
5323C
5324C Init a 0
5325 DO i = 1, nodfi*nthread
5326 afi(nin)%P(1,i) = zero
5327 afi(nin)%P(2,i) = zero
5328 afi(nin)%P(3,i) = zero
5329 stnfi(nin)%P(i) = zero
5330 fthefi(nin)%P(i) = zero
5331 ENDDO
5332 IF(nodadt_therm ==1) THEN
5333 DO i = 1, nodfi*nthread
5334 condnfi(nin)%P(i) = zero
5335 ENDDO
5336 ENDIF
5337C
5338 IF(kdtint/=0)THEN
5339 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
5340 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi),stat=ierror3)
5341C Init a 0
5342 DO i = 1, nodfi
5343 vscfi(nin)%P(i) = zero
5344 ENDDO
5345 ENDIF
5346C
5347 ELSE ! IF PARITH/ON
5348C
5349C Allocation Parith/ON done in UPGRADE_REM_2RY
5350C
5351 ENDIF !PARITH/ON
5352 ENDIF !INTTH
5353 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
5354 CALL ancmsg(msgid=20,anmode=aninfo)
5355 CALL arret(2)
5356 ENDIF
5357C
5358C renumbering of candidates
5359C
5360 DO i = 1, i_stok
5361 n = cand_s(i)
5362 nn = n-nrts
5363 IF(nn>0)THEN
5364 cand_s(i) = index(nn)+nrts
5365 ENDIF
5366 ENDDO
5367C
5368#endif
5369 RETURN
tri7box::condnfi
type(real_pointer), dimension(:), allocatable condnfi
Definition tri7box.F:449
tri7box::inflg_subsfi
type(int_pointer), dimension(:), allocatable inflg_subsfi
Definition tri7box.F:505
tri7box::matsfi
type(int_pointer), dimension(:), allocatable matsfi
Definition tri7box.F:440
tri7box::tempfi
type(real_pointer), dimension(:), allocatable tempfi
Definition tri7box.F:449
tri7box::penfi
type(real_pointer2), dimension(:), allocatable penfi
Definition tri7box.F:459
tri7box::lisubsfi
type(int_pointer), dimension(:), allocatable lisubsfi
Definition tri7box.F:501
tri7box::areasfi
type(real_pointer), dimension(:), allocatable areasfi
Definition tri7box.F:449
tri7box::addsubsfi
type(int_pointer), dimension(:), allocatable addsubsfi
Definition tri7box.F:509
tri7box::ipartfricsfi
type(int_pointer), dimension(:), allocatable ipartfricsfi
Definition tri7box.F:440
tri7box::fthefi
type(real_pointer), dimension(:), allocatable fthefi
Definition tri7box.F:449

◆ spmd_tri11vox()

subroutine spmd_tri11vox ( integer, dimension(2,nrts) irects,
integer nrts,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifs,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nrtsr,
integer inacti,
gap_s,
penis,
integer, dimension(*) itab,
integer igap,
tzinf,
integer, dimension(*) nodnx_sms,
gap_s_l,
integer, dimension(*) nsnfiold,
integer iform,
integer intth,
integer, dimension(*) ielec,
areas,
temp,
integer nisub,
integer, dimension(*) addsubs,
integer, dimension(*) lisubs,
integer intfric,
integer, dimension(*) ipartfrics,
integer, dimension(*) inflg_subs )

Definition at line 4388 of file spmd_int.F.

4396C-----------------------------------------------
4397C M o d u l e s
4398C-----------------------------------------------
4399 USE tri7box
4400 USE message_mod
4401 USE spmd_mod
4402C-----------------------------------------------
4403C I m p l i c i t T y p e s
4404C-----------------------------------------------
4405#include "implicit_f.inc"
4406C-----------------------------------------------
4407C C o m m o n B l o c k s
4408C-----------------------------------------------
4409#include "com01_c.inc"
4410#include "com04_c.inc"
4411#include "task_c.inc"
4412#include "timeri_c.inc"
4413#include "sms_c.inc"
4414C-----------------------------------------------
4415C D u m m y A r g u m e n t s
4416C-----------------------------------------------
4417 INTEGER NIN, INACTI, IGAP, NRTS,NRTSR, INTFRIC,
4418 . WEIGHT(*),IRECTS(2,NRTS),
4419 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
4420 . IAD_ELEM(2,*), FR_ELEM(*), ITAB(*),
4421 . NODNX_SMS(*),NSNFIOLD(*),IFORM,INTTH,IELEC(*),
4422 . NISUB,ADDSUBS(*),LISUBS(*),IPARTFRICS(*),INFLG_SUBS(*)
4423
4424 my_real
4425 . x(3,*), v(3,*), ms(*), bminmal(6),
4426 . stifs(nrts), gap_s(nrts),
4427 . gap_s_l(*), tzinf, penis(2,*),areas(*),temp(*)
4428C-----------------------------------------------
4429C L o c a l V a r i a b l e s
4430C-----------------------------------------------
4431#ifdef MPI
4432 INTEGER MSGTYP, I, LOC_PROC, P, IDEB,
4433 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4,
4434 . SIZ,J, L, LEN, NB, IERROR1, IAD,
4435 . IERROR,REQ_SB(NSPMD),
4436 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
4437 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
4438 . REQ_RC(NSPMD),REQ_SC(NSPMD),
4439 . INDEXI,ISINDEXI(NSPMD),INDEX(NRTS),NBOX(NSPMD),
4440 . NBX,NBY,NBZ,IX,IY,IZ, N1, N2,
4441 . IX1,IY1,IZ1,IX2,IY2,IZ2, NOD,
4442 . RSIZ, ISIZ, L2, REQ_SD3(NSPMD),
4443 . REQ_RD2(NSPMD), RSHIFT, ISHIFT, LEN2, K,LL
4444 my_real
4445 . bminma(6,nspmd),
4446 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
4447 . xmins, ymins, zmins, xmaxs, ymaxs, zmaxs,
4448 . dx, dy, dz
4449
4450 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
4451 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
4452
4453 DATA msgoff/6009/
4454 DATA msgoff2/6010/
4455 DATA msgoff3/6011/
4456 DATA msgoff4/6012/
4457C-----------------------------------------------
4458C S o u r c e L i n e s
4459C-----------------------------------------------
4460C
4461C=======================================================================
4462C tag of boxes containing facets
4463C and creation of candidates
4464C=======================================================================
4465 loc_proc = ispmd + 1
4466
4467 nbx = lrvoxel
4468 nby = lrvoxel
4469 nbz = lrvoxel
4470
4471C Old value backup of the NSN Frontieres
4472C
4473 IF(iform == 2) THEN
4474 DO p = 1, nspmd
4475 nsnfiold(p) = nsnfi(nin)%P(p)
4476 END DO
4477 END IF
4478C
4479C
4480C
4481C minmax box for sorting from i11uce BMINMA
4482C
4483 IF(ircvfrom(nin,loc_proc)==0.AND.
4484 . isendto(nin,loc_proc)==0) RETURN
4485 bminma(1,loc_proc) = bminmal(1)
4486 bminma(2,loc_proc) = bminmal(2)
4487 bminma(3,loc_proc) = bminmal(3)
4488 bminma(4,loc_proc) = bminmal(4)
4489 bminma(5,loc_proc) = bminmal(5)
4490 bminma(6,loc_proc) = bminmal(6)
4491C
4492C Voxel shipment + min/max box
4493C
4494 IF(ircvfrom(nin,loc_proc)/=0) THEN
4495 DO p = 1, nspmd
4496 IF(isendto(nin,p)/=0) THEN
4497 IF(p/=loc_proc) THEN
4498 msgtyp = msgoff
4499 CALL spmd_isend(
4500 . crvoxel(0,0,loc_proc),
4501 . (lrvoxel+1)*(lrvoxel+1),
4502 . it_spmd(p),msgtyp,req_sc(p))
4503 msgtyp = msgoff2
4504 CALL spmd_isend(bminma(1,loc_proc),6,it_spmd(p),msgtyp,req_sb(p))
4505 ENDIF
4506 ENDIF
4507 ENDDO
4508 ENDIF
4509C
4510C Voxel reception + min-max boxes
4511C
4512 IF(isendto(nin,loc_proc)/=0) THEN
4513 nbirecv=0
4514 DO p = 1, nspmd
4515 IF(ircvfrom(nin,p)/=0) THEN
4516 IF(loc_proc/=p) THEN
4517 nbirecv=nbirecv+1
4518 irindexi(nbirecv)=p
4519 msgtyp = msgoff
4520 CALL spmd_irecv(
4521 . crvoxel(0,0,p),
4522 . (lrvoxel+1)*(lrvoxel+1),
4523 . it_spmd(p),msgtyp,req_rc(nbirecv))
4524 msgtyp = msgoff2
4525 CALL spmd_irecv(
4526 . bminma(1,p) ,6,it_spmd(p),msgtyp,
4527 . req_rb(nbirecv))
4528 ENDIF
4529 ENDIF
4530 ENDDO
4531 ENDIF
4532C
4533C sending of XREM
4534C
4535c general case
4536 rsiz = 15
4537 isiz = 3
4538
4539c specific cases
4540c IGAP=1 or IGAP=2
4541 IF(igap==1.OR.igap==2) THEN
4542 rsiz = rsiz + 1
4543c IGAP=3
4544 ELSEIF(igap==3) THEN
4545 rsiz = rsiz + 2
4546 ENDIF
4547
4548c INACTI = 5 or 6
4549 IF(inacti==5.OR.inacti==6) rsiz = rsiz + 2
4550
4551C -- IDTMINS==2
4552 IF(idtmins == 2)THEN
4553 isiz = isiz + 4
4554C -- IDTMINS_INT /= 0
4555 ELSEIF(idtmins_int/=0)THEN
4556 isiz = isiz + 2
4557 END IF
4558 IF(intth > 0)THEN
4559 rsiz = rsiz + 3
4560 isiz = isiz + 1
4561 ENDIF
4562C Friction
4563 IF(intfric > 0 ) THEN
4564 isiz = isiz + 1
4565 ENDIF
4566
4567C -- SUBINTERFACES
4568 IF (nisub > 0) THEN
4569 isiz = isiz + 1 + nisub
4570 isiz = isiz + nisub
4571 ENDIF
4572C
4573 ideb = 1
4574
4575 IF(isendto(nin,loc_proc)/=0) THEN
4576 DO kk = 1, nbirecv
4577 CALL spmd_waitany(nbirecv,req_rb,indexi)
4578 p=irindexi(indexi)
4579
4580
4581 CALL spmd_wait(req_rc(indexi))
4582C special treatment on d.d. to keep only internal nodes
4583! DO J = IAD_ELEM(1,P), IAD_ELEM(1,P+1)-1
4584! NOD = FR_ELEM(J)
4585!C weight < 0 temporarily to keep only non-border nodes
4586! WEIGHT(NOD) = WEIGHT(NOD)*(-1)
4587! ENDDO
4588C
4589 l = ideb
4590 nbox(p) = 0
4591 nb = 0
4592 xmaxb = bminma(1,p)
4593 ymaxb = bminma(2,p)
4594 zmaxb = bminma(3,p)
4595 xminb = bminma(4,p)
4596 yminb = bminma(5,p)
4597 zminb = bminma(6,p)
4598 dx=xmaxb-xminb
4599 dy=ymaxb-yminb
4600 dz=zmaxb-zminb
4601 DO i=1,nrts
4602 n1=irects(1,i)
4603 n2=irects(2,i)
4604 IF(stifs(i)>zero) THEN
4605 xmins = min(x(1,n1),x(1,n2))!-TZINF
4606 ymins = min(x(2,n1),x(2,n2))!-TZINF
4607 zmins = min(x(3,n1),x(3,n2))!-TZINF
4608 xmaxs = max(x(1,n1),x(1,n2))!+TZINF
4609 ymaxs = max(x(2,n1),x(2,n2))!+TZINF
4610 zmaxs = max(x(3,n1),x(3,n2))!+TZINF
4611 ix1=int(nbx*(xmins-xminb)/dx)
4612 ix2=int(nbx*(xmaxs-xminb)/dx)
4613 IF(ix2>=0.AND.ix1<=nbx)THEN
4614 iy1=int(nby*(ymins-yminb)/dy)
4615 iy2=int(nby*(ymaxs-yminb)/dy)
4616 IF(iy2>=0.AND.iy1<=nby)THEN
4617 iz1=int(nbz*(zmins-zminb)/dz)
4618 iz2=int(nbz*(zmaxs-zminb)/dz)
4619 IF(iz2>=0.AND.iz1<=nbz)THEN
4620 ix1=max(ix1,0)
4621 ix2=min(ix2,nbx)
4622 iy1=max(iy1,0)
4623 iy2=min(iy2,nbx)
4624 iz1=max(iz1,0)
4625 iz2=min(iz2,nbx)
4626 DO ix=ix1,ix2
4627 DO iy=iy1,iy2
4628 DO iz=iz1,iz2
4629 IF(btest(crvoxel(iy,iz,p),ix)) THEN
4630 nb = nb + 1
4631 index(nb) = i
4632 GOTO 111 !next I
4633 END IF
4634 END DO
4635 END DO
4636 END DO
4637 ENDIF
4638 ENDIF
4639 ENDIF
4640
4641 111 CONTINUE
4642
4643 ENDIF !(STIFS(I)>ZERO)
4644
4645 ENDDO !I=1,NRTS
4646 nbox(p) = nb
4647C
4648C
4649C Envoi taille msg
4650C
4651 msgtyp = msgoff3
4652 CALL spmd_isend(nbox(p),1,it_spmd(p),msgtyp,
4653 . req_sd(p))
4654C
4655C Alloc buffer
4656C
4657 IF (nb>0) THEN
4658 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
4659 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
4660 IF(ierror/=0) THEN
4661 CALL ancmsg(msgid=20,anmode=aninfo)
4662 CALL arret(2)
4663 ENDIF
4664 l = 0
4665 l2= 0
4666C
4667c general case
4668 DO j = 1, nb
4669 i = index(j)
4670 n1=irects(1,i)
4671 n2=irects(2,i)
4672 rbuf(p)%p(l+1) = x(1,n1)
4673 rbuf(p)%p(l+2) = x(2,n1)
4674 rbuf(p)%p(l+3) = x(3,n1)
4675 rbuf(p)%p(l+4) = v(1,n1)
4676 rbuf(p)%p(l+5) = v(2,n1)
4677 rbuf(p)%p(l+6) = v(3,n1)
4678 rbuf(p)%p(l+7) = ms(n1)
4679 rbuf(p)%p(l+8)= x(1,n2)
4680 rbuf(p)%p(l+9)= x(2,n2)
4681 rbuf(p)%p(l+10)= x(3,n2)
4682 rbuf(p)%p(l+11)= v(1,n2)
4683 rbuf(p)%p(l+12)= v(2,n2)
4684 rbuf(p)%p(l+13)= v(3,n2)
4685 rbuf(p)%p(l+14)= ms(n2)
4686 rbuf(p)%p(l+15)= stifs(i)
4687 ibuf(p)%p(l2+1)= i
4688 ibuf(p)%p(l2+2)= itab(n1)
4689 ibuf(p)%p(l2+3)= itab(n2)
4690 l = l + rsiz
4691 l2 = l2 + isiz
4692 END DO
4693
4694c shift for real variables
4695 rshift = 16
4696c shift for integer variables
4697 ishift = 4
4698
4699c specific cases
4700c IGAP=1 or IGAP=2
4701 IF(igap==1 .OR. igap==2)THEN
4702 l = 0
4703 DO j = 1, nb
4704 i = index(j)
4705 rbuf(p)%p(l+rshift)= gap_s(i)
4706 l = l + rsiz
4707 ENDDO
4708 rshift = rshift + 1
4709c IGAP=3
4710 ELSEIF(igap==3)THEN
4711 l = 0
4712 DO j = 1, nb
4713 i = index(j)
4714 rbuf(p)%p(l+rshift) = gap_s(i)
4715 rbuf(p)%p(l+rshift+1)= gap_s_l(i)
4716 l = l + rsiz
4717 END DO
4718 rshift = rshift + 2
4719 ENDIF
4720C thermic
4721 IF(intth>0)THEN
4722 l = 0
4723 l2 = 0
4724 DO j = 1, nb
4725 i = index(j)
4726 n1=irects(1,i)
4727 n2=irects(2,i)
4728 rbuf(p)%p(l+rshift) = temp(n1)
4729 rbuf(p)%p(l+rshift+1) = temp(n2)
4730 rbuf(p)%p(l+rshift+2) = areas(i)
4731 ibuf(p)%p(l2+ishift) = ielec(i)
4732 l = l + rsiz
4733 l2 = l2 + isiz
4734 END DO
4735 rshift = rshift + 3
4736 ishift = ishift + 1
4737 ENDIF
4738
4739C Friction
4740 IF(intfric>0)THEN
4741 l2 = 0
4742 DO j = 1, nb
4743 i = index(j)
4744 ibuf(p)%p(l2+ishift) = ipartfrics(i)
4745 l2 = l2 + isiz
4746 END DO
4747 ishift = ishift + 1
4748 ENDIF
4749
4750c INACTI = 5 or 6
4751 IF(inacti==5.OR.inacti==6)THEN
4752 l = 0
4753 DO j = 1, nb
4754 i = index(j)
4755 rbuf(p)%p(l+rshift) = penis(1,i)
4756 rbuf(p)%p(l+rshift+1)= penis(2,i)
4757 l = l + rsiz
4758 ENDDO
4759 rshift = rshift + 2
4760 ENDIF
4761
4762C -- IDTMINS==2
4763 IF(idtmins==2)THEN
4764 l2 = 0
4765 DO j = 1, nb
4766 i = index(j)
4767 n1=irects(1,i)
4768 n2=irects(2,i)
4769 ibuf(p)%p(l2+ishift) = nodnx_sms(n1)
4770 ibuf(p)%p(l2+ishift+1)= n1
4771 ibuf(p)%p(l2+ishift+2)= nodnx_sms(n2)
4772 ibuf(p)%p(l2+ishift+3)= n2
4773 l2 = l2 + isiz
4774 END DO
4775 ishift = ishift + 4
4776C -- IDTMINS_INT /= 0
4777 ELSEIF(idtmins_int/=0)THEN
4778 l2 = 0
4779 DO j = 1, nb
4780 i = index(j)
4781 n1=irects(1,i)
4782 n2=irects(2,i)
4783 ibuf(p)%p(l2+ishift) = n1
4784 ibuf(p)%p(l2+ishift+1)= n2
4785 l2 = l2 + isiz
4786 END DO
4787 ishift = ishift + 2
4788 ENDIF
4789
4790C-- SUBINTERFACES
4791 IF(nisub > 0)THEN
4792 l2 = 0
4793 DO j = 1, nb
4794 i = index(j)
4795 ibuf(p)%p(l2+ishift) = addsubs(i+1)-addsubs(i)
4796 ll = 0
4797 DO k = 1,addsubs(i+1)-addsubs(i)
4798 ll = ll + 1
4799 ibuf(p)%p(l2+ishift+ll)=lisubs(addsubs(i)+k-1)
4800 ll = ll + 1
4801 ibuf(p)%p(l2+ishift+ll)=inflg_subs(addsubs(i)+k-1)
4802 END DO
4803 l2 = l2 + isiz
4804 END DO
4805 ishift = ishift + 2*nisub + 1
4806 ENDIF
4807C
4808 msgtyp = msgoff4
4809 CALL spmd_isend(
4810 1 rbuf(p)%P(1),nb*rsiz,it_spmd(p),msgtyp,
4811 2 req_sd2(p))
4812
4813 msgtyp = msgoff4
4814 CALL spmd_isend(
4815 1 ibuf(p)%P(1),nb*isiz,it_spmd(p),msgtyp,
4816 2 req_sd3(p))
4817 ENDIF !ENDIF NB > 0
4818 ENDDO !ENDDO KK = 1, NBIRECV
4819 ENDIF !ENDIF SENDTO(NIN,LOC_PROC)/=0
4820C
4821C
4822C reception of XREM data
4823C
4824 IF(ircvfrom(nin,loc_proc)/=0) THEN
4825 nrtsr = 0
4826 l=0
4827 DO p = 1, nspmd
4828 nsnfi(nin)%P(p) = 0
4829 IF(isendto(nin,p)/=0) THEN
4830 IF(loc_proc/=p) THEN
4831 msgtyp = msgoff3
4832 CALL spmd_recv(nsnfi(nin)%P(p),1,it_spmd(p),msgtyp)
4833 IF(nsnfi(nin)%P(p)>0) THEN
4834 l=l+1
4835 isindexi(l)=p
4836 nrtsr = nrtsr + nsnfi(nin)%P(p)
4837 ENDIF
4838 ENDIF
4839 ENDIF
4840 ENDDO
4841 nbirecv=l
4842C
4843C Allocate total size
4844C
4845 IF(nrtsr>0) THEN
4846 ALLOCATE(xrem(rsiz,nrtsr),stat=ierror)
4847 ALLOCATE(irem(isiz,nrtsr),stat=ierror1)
4848
4849 ierror=ierror+ierror1
4850 IF(ierror/=0) THEN
4851 CALL ancmsg(msgid=20,anmode=aninfo)
4852 CALL arret(2)
4853 ENDIF
4854 ideb = 1
4855 DO l = 1, nbirecv
4856 p = isindexi(l)
4857 len = nsnfi(nin)%P(p)*rsiz
4858 msgtyp = msgoff4
4859 CALL spmd_irecv(xrem(1,ideb),len,it_spmd(p),msgtyp,req_rd(l))
4860
4861 len2 = nsnfi(nin)%P(p)*isiz
4862 msgtyp = msgoff4
4863 CALL spmd_irecv(irem(1,ideb),len2,it_spmd(p),msgtyp,req_rd2(l))
4864
4865 ideb = ideb + nsnfi(nin)%P(p)
4866 ENDDO
4867 DO l = 1, nbirecv
4868 CALL spmd_waitany(nbirecv,req_rd,indexi)
4869 CALL spmd_waitany(nbirecv,req_rd2,indexi)
4870 ENDDO
4871 ENDIF
4872 ENDIF
4873C
4874 IF(ircvfrom(nin,loc_proc)/=0) THEN
4875 DO p = 1, nspmd
4876 IF(isendto(nin,p)/=0) THEN
4877 IF(p/=loc_proc) THEN
4878 CALL spmd_wait(req_sb(p))
4879 CALL spmd_wait(req_sc(p))
4880 ENDIF
4881 ENDIF
4882 ENDDO
4883 ENDIF
4884C
4885 IF(isendto(nin,loc_proc)/=0) THEN
4886 DO p = 1, nspmd
4887 IF(ircvfrom(nin,p)/=0) THEN
4888 IF(p/=loc_proc) THEN
4889 CALL spmd_wait(req_sd(p))
4890 IF(nbox(p)/=0) THEN
4891 CALL spmd_wait(req_sd2(p))
4892 DEALLOCATE(rbuf(p)%p)
4893 CALL spmd_wait(req_sd3(p))
4894 DEALLOCATE(ibuf(p)%p)
4895 END IF
4896 ENDIF
4897 ENDIF
4898 ENDDO
4899 ENDIF
4900#endif
4901 RETURN
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
tri7box::crvoxel
integer, dimension(0:lrvoxel, 0:lrvoxel) crvoxel
Definition tri7box.F:56
tri7box::lrvoxel
integer lrvoxel
Definition tri7box.F:54

◆ spmd_tri11vox0()

subroutine spmd_tri11vox0 ( x,
bminmal,
integer igap,
integer nrtm,
stf,
tzinf,
integer, dimension(2,nrtm) irectm,
gap,
gap_m,
gapmin,
bgapsmx,
intent(in) drad,
intent(in) dgapload )

Definition at line 4241 of file spmd_int.F.

4245C-----------------------------------------------
4246C M o d u l e s
4247C-----------------------------------------------
4248 USE tri7box
4249 USE spmd_mod
4250C-----------------------------------------------
4251C I m p l i c i t T y p e s
4252C-----------------------------------------------
4253#include "implicit_f.inc"
4254#include "comlock.inc"
4255C-----------------------------------------------
4256C C o m m o n B l o c k s
4257C-----------------------------------------------
4258#include "task_c.inc"
4259C-----------------------------------------------
4260C D u m m y A r g u m e n t s
4261C-----------------------------------------------
4262 INTEGER IGAP, NRTM, IRECTM(2,NRTM)
4263 my_real
4264 . x(3,*), bminmal(6),gap_m(*),gapmin,bgapsmx,
4265 . stf(nrtm),
4266 . tzinf,gap
4267 my_real , INTENT(IN) :: drad,dgapload
4268C-----------------------------------------------
4269C L o c a l V a r i a b l e s
4270C-----------------------------------------------
4271 INTEGER LOC_PROC,
4272 . NBX,NBY,NBZ,NEDG,M1,M2,M3,M4,
4273 . IX1,IY1,IZ1,IX2,IY2,IZ2,IX,IY,IZ,I
4274 my_real
4275 . ratio, aaa, marge,
4276 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
4277 . xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,
4278 . xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4
4279 INTEGER TMP
4280C-----------------------------------------------
4281C S o u r c e L i n e s
4282C-----------------------------------------------
4283C
4284C=======================================================================
4285C tag of boxes containing facets
4286C and creation of candidates
4287C=======================================================================
4288
4289 loc_proc = ispmd + 1
4290 !MARGE = TZINF-GAP
4291 marge = tzinf-max(gap+dgapload,drad)
4292
4293
4294 nbx = lrvoxel
4295 nby = lrvoxel
4296 nbz = lrvoxel
4297
4298 xmaxb = bminmal(1)
4299 ymaxb = bminmal(2)
4300 zmaxb = bminmal(3)
4301 xminb = bminmal(4)
4302 yminb = bminmal(5)
4303 zminb = bminmal(6)
4304
4305 aaa = 0
4306 DO nedg=1,nrtm
4307C We do not retain the Destruit facets
4308 IF(stf(nedg) == zero)cycle
4309
4310 aaa = tzinf
4311c AAA = ZERO
4312
4313 IF(igap == 0)THEN
4314 aaa = tzinf
4315 ELSE
4316 aaa = marge+
4317 . max(max(gapmin,bgapsmx+gap_m(nedg))+dgapload,drad)
4318 ENDIF
4319
4320
4321 m1 = irectm(1,nedg)
4322 m2 = irectm(2,nedg)
4323
4324 xx1=x(1,m1)
4325 xx2=x(1,m2)
4326 xmaxe=max(xx1,xx2)
4327 xmine=min(xx1,xx2)
4328
4329 yy1=x(2,m1)
4330 yy2=x(2,m2)
4331 ymaxe=max(yy1,yy2)
4332 ymine=min(yy1,yy2)
4333
4334 zz1=x(3,m1)
4335 zz2=x(3,m2)
4336 zmaxe=max(zz1,zz2)
4337 zmine=min(zz1,zz2)
4338
4339c index of voxels occupied by the facet
4340
4341 ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
4342 iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
4343 iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
4344
4345 ix1=max(0,min(nbx,ix1))
4346 iy1=max(0,min(nby,iy1))
4347 iz1=max(0,min(nbz,iz1))
4348
4349 ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
4350 iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
4351 iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
4352
4353 ix2=max(0,min(nbx,ix2))
4354 iy2=max(0,min(nby,iy2))
4355 iz2=max(0,min(nbz,iz2))
4356
4357 DO iz = iz1, iz2
4358 DO iy = iy1, iy2
4359 tmp = 0
4360 DO ix = ix1, ix2
4361 tmp=ibset(tmp,ix)
4362 END DO
4363!$OMP ATOMIC
4364 crvoxel(iy,iz,loc_proc)=ior(crvoxel(iy,iz,loc_proc),tmp)
4365 END DO
4366 END DO
4367
4368
4369 ENDDO
4370C
4371 RETURN

◆ spmd_tri18_151vox()

subroutine spmd_tri18_151vox ( integer, dimension(*) nsv,
integer nsn,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifn,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nsnr,
integer igap,
gap_s,
integer, dimension(*) itab,
integer, dimension(*) kinet,
integer ifq,
integer inacti,
integer, dimension(*) nsnfiold,
integer intth,
integer, dimension(*) ielec,
areas,
temp,
integer num_imp,
integer, dimension(*) nodnx_sms,
gap_s_l,
integer ityp,
integer, dimension(*) irtlm,
i24_time_s,
i24_frfi,
i24_pene_old,
i24_stif_old,
integer, dimension(*) nbinflg,
integer ilev,
integer, dimension(*) i24_icont_i,
integer, dimension(nixs, *) ixs,
type (multi_fvm_struct), intent(in) multi_fvm,
integer intfric,
integer, dimension(*) ipartfrics )

Definition at line 884 of file spmd_int.F.

894C-----------------------------------------------
895C M o d u l e s
896C-----------------------------------------------
897 USE tri7box
898 USE message_mod
899 USE multi_fvm_mod
900 USE spmd_mod
901 use element_mod , only :nixs
902C-----------------------------------------------
903C I m p l i c i t T y p e s
904C-----------------------------------------------
905#include "implicit_f.inc"
906C-----------------------------------------------
907C M e s s a g e P a s s i n g
908C-----------------------------------------------
909C-----------------------------------------------
910C C o m m o n B l o c k s
911C-----------------------------------------------
912#include "com01_c.inc"
913#include "com04_c.inc"
914#include "task_c.inc"
915#include "timeri_c.inc"
916#include "sms_c.inc"
917C-----------------------------------------------
918C D u m m y A r g u m e n t s
919C-----------------------------------------------
920 INTEGER NIN, NSN, IFQ, INACTI, IGAP,INTTH,INTFRIC,
921 . NSNFIOLD(*), NSV(*), WEIGHT(*),
922 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
923 . IAD_ELEM(2,*), FR_ELEM(*), ITAB(*), KINET(*),
924 . IELEC(*),NUM_IMP, NODNX_SMS(*),IRTLM(*),ITYP,
925 . NBINFLG(*),ILEV,I24_ICONT_I(*),NSNR,IXS(NIXS, *),
926 . IPARTFRICS(*)
927
928 my_real
929 . x(3,*), v(3,*), ms(*), bminmal(*), stifn(*), gap_s(*),
930 . areas(*),temp(*),gap_s_l(*),i24_time_s(*),i24_frfi(6,*),
931 . i24_pene_old(5,*),i24_stif_old(2,*)
932
933 TYPE (MULTI_FVM_STRUCT), INTENT(IN) :: MULTI_FVM
934C-----------------------------------------------
935C L o c a l V a r i a b l e s
936C-----------------------------------------------
937#ifdef MPI
938 INTEGER MSGTYP, I, NOD, LOC_PROC, P, IDEB,
939 . SIZ,J, L, BUFSIZ, LEN, NB, IERROR1, IAD,
940 . IERROR,REQ_SB(NSPMD),
941 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
942 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
943 . REQ_RC(NSPMD),REQ_SC(NSPMD),
944 . INDEXI,ISINDEXI(NSPMD),INDEX(NUMNOD),NBOX(NSPMD),
945 . NBX,NBY,NBZ,IX,IY,IZ,
946 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5,
947 . RSIZ, ISIZ, L2, REQ_SD3(NSPMD),REQ_RD2(NSPMD),
948 . LEN2, RSHIFT, ISHIFT, ND, JDEB, Q, NBB
949
950 DATA msgoff/6000/
951 DATA msgoff2/6001/
952 DATA msgoff3/6002/
953 DATA msgoff4/6003/
954 DATA msgoff5/6004/
955
956 my_real
957 . bminma(6,nspmd),
958 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb
959
960 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
961 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
962
963
964C-----------------------------------------------
965C S o u r c e L i n e s
966C-----------------------------------------------
967C
968C=======================================================================
969C tag of the boxes containing facets
970C and creation of candidates
971C=======================================================================
972 loc_proc = ispmd + 1
973
974 nbx = lrvoxel
975 nby = lrvoxel
976 nbz = lrvoxel
977C
978C Old value backup of the NSN Frontieres
979C
980 IF(inacti==5.OR.inacti==6.OR.inacti==7.OR.ifq>0
981 . .OR.num_imp>0.OR.ityp==23.OR.ityp==24
982 . .OR.ityp==25) THEN
983 DO p = 1, nspmd
984 nsnfiold(p) = nsnfi(nin)%P(p)
985 END DO
986 END IF
987C
988C minmax box for sorting coming from i7buce BMINMA
989C
990 IF(ircvfrom(nin,loc_proc)==0.AND.
991 . isendto(nin,loc_proc)==0) RETURN
992 bminma(1,loc_proc) = bminmal(1)
993 bminma(2,loc_proc) = bminmal(2)
994 bminma(3,loc_proc) = bminmal(3)
995 bminma(4,loc_proc) = bminmal(4)
996 bminma(5,loc_proc) = bminmal(5)
997 bminma(6,loc_proc) = bminmal(6)
998C
999C Voxel shipment + min/max box
1000C
1001 IF(ircvfrom(nin,loc_proc)/=0) THEN
1002 DO p = 1, nspmd
1003 IF(isendto(nin,p)/=0) THEN
1004 IF(p/=loc_proc) THEN
1005 msgtyp = msgoff
1006 CALL spmd_isend(
1007 . crvoxel(0,0,loc_proc),
1008 . (lrvoxel+1)*(lrvoxel+1),
1009 .
1010 . it_spmd(p),msgtyp,req_sc(p))
1011 msgtyp = msgoff2
1012 CALL spmd_isend(
1013 . bminma(1,loc_proc),6 ,it_spmd(p),msgtyp,
1014 . req_sb(p))
1015 ENDIF
1016 ENDIF
1017 ENDDO
1018 ENDIF
1019C
1020C Voxel reception + min-max boxes
1021C
1022 IF(isendto(nin,loc_proc)/=0) THEN
1023 nbirecv=0
1024 DO p = 1, nspmd
1025 IF(ircvfrom(nin,p)/=0) THEN
1026 IF(loc_proc/=p) THEN
1027 nbirecv=nbirecv+1
1028 irindexi(nbirecv)=p
1029 msgtyp = msgoff
1030 CALL spmd_irecv(
1031 . crvoxel(0,0,p),
1032 . (lrvoxel+1)*(lrvoxel+1),
1033 . it_spmd(p),msgtyp,req_rc(nbirecv))
1034 msgtyp = msgoff2
1035 CALL spmd_irecv(
1036 . bminma(1,p) ,6 ,it_spmd(p),msgtyp,
1037 . req_rb(nbirecv))
1038 ENDIF
1039 ENDIF
1040 ENDDO
1041 ENDIF
1042C
1043C sending XREM
1044C
1045C computation of real and integer sending buffers sizes
1046c general case
1047 rsiz = 8
1048 isiz = 6
1049
1050c specific cases
1051c IGAP=1 or IGAP=2
1052 IF(igap==1 .OR. igap==2)THEN
1053 rsiz = rsiz + 1
1054c IGAP=3
1055 ELSEIF(igap==3)THEN
1056 rsiz = rsiz + 2
1057 ENDIF
1058
1059C thermic
1060 IF(intth > 0 ) THEN
1061 rsiz = rsiz + 2
1062 isiz = isiz + 1
1063 ENDIF
1064
1065C Friction
1066 IF(intfric > 0 ) THEN
1067 isiz = isiz + 1
1068 ENDIF
1069
1070C -- IDTMINS==2
1071 IF(idtmins == 2)THEN
1072 isiz = isiz + 2
1073C -- IDTMINS_INT /= 0
1074 ELSEIF(idtmins_int/=0)THEN
1075 isiz = isiz + 1
1076 END IF
1077
1078
1079 ideb = 1
1080
1081 jdeb = 0
1082
1083 IF(isendto(nin,loc_proc)/=0) THEN
1084 DO kk = 1, nbirecv
1085 CALL spmd_waitany(nbirecv,req_rb,indexi)
1086 p=irindexi(indexi)
1087 CALL spmd_wait(req_rc(indexi))
1088
1089 l = ideb
1090 nbox(p) = 0
1091 nb = 0
1092 xmaxb = bminma(1,p)
1093 ymaxb = bminma(2,p)
1094 zmaxb = bminma(3,p)
1095 xminb = bminma(4,p)
1096 yminb = bminma(5,p)
1097 zminb = bminma(6,p)
1098 DO i=1,nsn
1099 nod = nsv(i)
1100 IF(stifn(i)>zero)THEN
1101 IF(x(1,nod) < xminb) cycle
1102 IF(x(1,nod) > xmaxb) cycle
1103 IF(x(2,nod) < yminb) cycle
1104 IF(x(2,nod) > ymaxb) cycle
1105 IF(x(3,nod) < zminb) cycle
1106 IF(x(3,nod) > zmaxb) cycle
1107
1108 ix=int(nbx*(x(1,nod)-xminb)/(xmaxb-xminb))
1109 IF(ix >= 0 .AND. ix <= nbx) THEN
1110 iy=int(nby*(x(2,nod)-yminb)/(ymaxb-yminb))
1111 IF(iy >= 0 .AND. iy <= nby) THEN
1112 iz=int(nbz*(x(3,nod)-zminb)/(zmaxb-zminb))
1113 IF(iz >= 0 .AND. iz <= nbz) THEN
1114 IF(btest(crvoxel(iy,iz,p),ix)) THEN
1115 nb = nb + 1
1116 index(nb) = i
1117 ENDIF
1118 ENDIF
1119 ENDIF
1120 ENDIF
1121 ENDIF
1122 ENDDO
1123 nbox(p) = nb
1124C
1125C Envoi taille msg
1126C
1127 msgtyp = msgoff3
1128 CALL spmd_isend(nbox(p),1,it_spmd(p),msgtyp,
1129 . req_sd(p))
1130C
1131C Alloc buffer
1132C
1133 IF (nb>0) THEN
1134 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
1135 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
1136 IF(ierror/=0) THEN
1137 CALL ancmsg(msgid=20,anmode=aninfo)
1138 CALL arret(2)
1139 ENDIF
1140 l = 0
1141 l2= 0
1142
1143c general case
1144 DO j = 1, nb
1145 i = index(j)
1146 nod = nsv(i)
1147 rbuf(p)%p(l+1) = x(1,nod)
1148 rbuf(p)%p(l+2) = x(2,nod)
1149 rbuf(p)%p(l+3) = x(3,nod)
1150 rbuf(p)%p(l+4) = v(1,nod)
1151 rbuf(p)%p(l+5) = v(2,nod)
1152 rbuf(p)%p(l+6) = v(3,nod)
1153 rbuf(p)%p(l+7) = ms(nod)
1154 rbuf(p)%p(l+8) = stifn(i)
1155 ibuf(p)%p(l2+1) = i
1156 ibuf(p)%p(l2+2) = ixs(nixs, nod - numnod)
1157 ibuf(p)%p(l2+3) = kinet(nod)
1158! save specifics IREM and XREM indexes for INT24 sorting
1159 ibuf(p)%p(l2+4) = 0 !IGAPXREMP
1160 ibuf(p)%p(l2+5) = 0 !I24XREMP
1161 ibuf(p)%p(l2+6) = 0 !I24IREMP
1162 l = l + rsiz
1163 l2 = l2 + isiz
1164 ENDDO
1165
1166c shift for real variables (prepare for next setting)
1167 rshift = 9
1168c shift for integer variables (prepare for next setting)
1169 ishift = 7
1170
1171c specific cases
1172c IGAP=1 or IGAP=2
1173 IF(igap==1 .OR. igap==2)THEN
1174 l = 0
1175 igapxremp = rshift
1176 DO j = 1, nb
1177 i = index(j)
1178 rbuf(p)%p(l+rshift)= gap_s(i)
1179 l = l + rsiz
1180 ENDDO
1181 rshift = rshift + 1
1182
1183c IGAP=3
1184 ELSEIF(igap==3)THEN
1185 l = 0
1186 igapxremp = rshift
1187 DO j = 1, nb
1188 i = index(j)
1189 rbuf(p)%p(l+rshift) = gap_s(i)
1190 rbuf(p)%p(l+rshift+1)= gap_s_l(i)
1191 l = l + rsiz
1192 END DO
1193 rshift = rshift + 2
1194 ENDIF
1195
1196C thermic
1197 IF(intth>0)THEN
1198 l = 0
1199 l2 = 0
1200 DO j = 1, nb
1201 i = index(j)
1202 nod = nsv(i)
1203 rbuf(p)%p(l+rshift) = temp(nod)
1204 rbuf(p)%p(l+rshift+1) = areas(i)
1205 ibuf(p)%p(l2+ishift) = ielec(i)
1206 l = l + rsiz
1207 l2 = l2 + isiz
1208 END DO
1209 rshift = rshift + 2
1210 ishift = ishift + 1
1211 ENDIF
1212
1213C Friction
1214 IF(intfric>0)THEN
1215 l2 = 0
1216 DO j = 1, nb
1217 i = index(j)
1218 ibuf(p)%p(l2+ishift) = ipartfrics(i)
1219 l2 = l2 + isiz
1220 END DO
1221 ishift = ishift + 1
1222 ENDIF
1223
1224C -- IDTMINS==2
1225 IF(idtmins==2)THEN
1226 l2 = 0
1227 DO j = 1, nb
1228 i = index(j)
1229 nod = nsv(i)
1230 ibuf(p)%p(l2+ishift) = nodnx_sms(nod)
1231 ibuf(p)%p(l2+ishift+1)= nod
1232 l2 = l2 + isiz
1233 END DO
1234 ishift = ishift + 2
1235
1236C -- IDTMINS_INT /= 0
1237 ELSEIF(idtmins_int/=0)THEN
1238 l2 = 0
1239 DO j = 1, nb
1240 i = index(j)
1241 nod = nsv(i)
1242 ibuf(p)%p(l2+ishift)= nod
1243 l2 = l2 + isiz
1244 END DO
1245 ishift = ishift + 1
1246 ENDIF
1247C
1248 !save specifics IREM and XREM indexes for INT24 sorting
1249 l2 = 0
1250 DO j = 1, nb
1251 i = index(j)
1252 nod = nsv(i)
1253 !save specifics IREM and XREM indexes for INT24 sorting
1254 ibuf(p)%p(l2+4) = igapxremp
1255 ibuf(p)%p(l2+5) = i24xremp
1256 ibuf(p)%p(l2+6) = i24iremp
1257 l2 = l2 + isiz
1258 END DO
1259
1260 msgtyp = msgoff4
1261
1262 CALL spmd_isend(
1263 1 rbuf(p)%P(1),nb*rsiz,it_spmd(p),msgtyp,
1264 2 req_sd2(p))
1265
1266 msgtyp = msgoff5
1267 CALL spmd_isend(
1268 1 ibuf(p)%P(1),nb*isiz,it_spmd(p),msgtyp,
1269 2 req_sd3(p))
1270
1271 ENDIF
1272 ENDDO
1273 ENDIF
1274C
1275C
1276C reception of XREM data
1277C
1278 IF(ircvfrom(nin,loc_proc)/=0) THEN
1279 nsnr = 0
1280 l=0
1281 DO p = 1, nspmd
1282 nsnfi(nin)%P(p) = 0
1283 IF(isendto(nin,p)/=0) THEN
1284 IF(loc_proc/=p) THEN
1285 msgtyp = msgoff3
1286 CALL spmd_recv(nsnfi(nin)%P(p),1,it_spmd(p),
1287 . msgtyp)
1288 IF(nsnfi(nin)%P(p)>0) THEN
1289 l=l+1
1290 isindexi(l)=p
1291 nsnr = nsnr + nsnfi(nin)%P(p)
1292 ENDIF
1293 ENDIF
1294 ENDIF
1295 ENDDO
1296 nbirecv=l
1297C
1298C Allocate total size
1299C
1300 IF(nsnr>0) THEN
1301
1302 ALLOCATE(xrem(rsiz,nsnr),stat=ierror)
1303 ALLOCATE(irem(isiz,nsnr),stat=ierror)
1304
1305 IF(ierror/=0) THEN
1306 CALL ancmsg(msgid=20,anmode=aninfo)
1307 CALL arret(2)
1308 ENDIF
1309 ideb = 1
1310 DO l = 1, nbirecv
1311 p = isindexi(l)
1312 len = nsnfi(nin)%P(p)*rsiz
1313 msgtyp = msgoff4
1314
1315 CALL spmd_irecv(
1316 1 xrem(1,ideb),len,it_spmd(p),
1317 2 msgtyp,req_rd(l))
1318
1319 len2 = nsnfi(nin)%P(p)*isiz
1320 msgtyp = msgoff5
1321 CALL spmd_irecv(
1322 1 irem(1,ideb),len2,it_spmd(p),
1323 2 msgtyp,req_rd2(l))
1324 ideb = ideb + nsnfi(nin)%P(p)
1325 ENDDO
1326 DO l = 1, nbirecv
1327 CALL spmd_waitany(nbirecv,req_rd,indexi)
1328 CALL spmd_waitany(nbirecv,req_rd2,indexi)
1329 ENDDO
1330
1331 !set specifics IREM and XREM indexes for INT24 sorting
1332 igapxremp = irem(4,1)
1333 i24xremp = irem(5,1)
1334 i24iremp = irem(6,1)
1335 ENDIF
1336 ENDIF
1337C
1338 IF(ircvfrom(nin,loc_proc)/=0) THEN
1339 DO p = 1, nspmd
1340 IF(isendto(nin,p)/=0) THEN
1341 IF(p/=loc_proc) THEN
1342 CALL spmd_wait(req_sb(p))
1343 CALL spmd_wait(req_sc(p))
1344 ENDIF
1345 ENDIF
1346 ENDDO
1347 ENDIF
1348C
1349 IF(isendto(nin,loc_proc)/=0) THEN
1350 DO p = 1, nspmd
1351 IF(ircvfrom(nin,p)/=0) THEN
1352 IF(p/=loc_proc) THEN
1353 CALL spmd_wait(req_sd(p))
1354 IF(nbox(p)/=0) THEN
1355 CALL spmd_wait(req_sd2(p))
1356 DEALLOCATE(rbuf(p)%p)
1357 CALL spmd_wait(req_sd3(p))
1358 DEALLOCATE(ibuf(p)%p)
1359 END IF
1360 ENDIF
1361 ENDIF
1362 ENDDO
1363 ENDIF
1364C
1365C
1366#endif
1367 RETURN
tri7box::i24iremp
integer i24iremp
Definition tri7box.F:423
tri7box::i24xremp
integer i24xremp
Definition tri7box.F:423
tri7box::igapxremp
integer igapxremp
Definition tri7box.F:423

◆ spmd_tri23vox0()

subroutine spmd_tri23vox0 ( x,
bminmal,
integer igap,
integer nrtm,
stf,
tzinf,
curv_max,
gapmin,
gapmax,
gap_m,
integer, dimension(4,*) irect,
gap,
bgapsmx,
integer, dimension(*) msr )

Definition at line 5381 of file spmd_int.F.

5385C-----------------------------------------------
5386C M o d u l e s
5387C-----------------------------------------------
5388 USE tri7box
5389 USE spmd_mod
5390C-----------------------------------------------
5391C I m p l i c i t T y p e s
5392C-----------------------------------------------
5393#include "implicit_f.inc"
5394#include "comlock.inc"
5395C-----------------------------------------------
5396C C o m m o n B l o c k s
5397C-----------------------------------------------
5398#include "task_c.inc"
5399C-----------------------------------------------
5400C D u m m y A r g u m e n t s
5401C-----------------------------------------------
5402 INTEGER IGAP, NRTM, IRECT(4,*), MSR(*)
5403 my_real
5404 . x(3,*), bminmal(*),
5405 . stf(*), gap_m(*), bgapsmx,
5406 . tzinf,gapmin,gapmax,gap,curv_max(nrtm)
5407C-----------------------------------------------
5408C L o c a l V a r i a b l e s
5409C-----------------------------------------------
5410 INTEGER LOC_PROC,
5411 . NBX,NBY,NBZ,NE,M1,M2,M3,M4,
5412 . IX1,IY1,IZ1,IX2,IY2,IZ2,IX,IY,IZ
5413 my_real
5414 . ratio, aaa, marge,
5415 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
5416 . xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,
5417 . xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4
5418c DATA IPWR2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,
5419c . 16384,32768,65536,131072,262144,524288,1048576,
5420c . 2097152,4194304,8388608,16777216,33554432,67108864,
5421c . 134217728,268435456,536870912,1073741824,2147483648/
5422C-----------------------------------------------
5423C S o u r c e L i n e s
5424C-----------------------------------------------
5425C
5426C=======================================================================
5427C tag of boxes containing facets
5428C and creation of candidates
5429C=======================================================================
5430
5431 loc_proc = ispmd + 1
5432 marge = tzinf-gap
5433
5434 nbx = lrvoxel
5435 nby = lrvoxel
5436 nbz = lrvoxel
5437
5438 xmaxb = bminmal(1)
5439 ymaxb = bminmal(2)
5440 zmaxb = bminmal(3)
5441 xminb = bminmal(4)
5442 yminb = bminmal(5)
5443 zminb = bminmal(6)
5444
5445 DO ne=1,nrtm
5446C We do not retain the Destruit facets
5447 IF(stf(ne) == zero)cycle
5448
5449 IF(igap == 0)THEN
5450 aaa = tzinf+sqrt(three)*curv_max(ne)
5451 ELSE
5452 aaa = marge+sqrt(three)*(curv_max(ne)+
5453 . min(gapmax,max(gapmin,bgapsmx+gap_m(ne))))
5454 ENDIF
5455
5456c It is possible to improve the algo by cutting the facet
5457c in 2 (4,3,6,9 ...) if the facet is large in front of AAA and inclinee
5458
5459 m1 = irect(1,ne)
5460 m2 = irect(2,ne)
5461 m3 = irect(3,ne)
5462 m4 = irect(4,ne)
5463
5464 xx1=x(1,m1)
5465 xx2=x(1,m2)
5466 xx3=x(1,m3)
5467 xx4=x(1,m4)
5468 xmaxe=max(xx1,xx2,xx3,xx4)
5469 xmine=min(xx1,xx2,xx3,xx4)
5470
5471 yy1=x(2,m1)
5472 yy2=x(2,m2)
5473 yy3=x(2,m3)
5474 yy4=x(2,m4)
5475 ymaxe=max(yy1,yy2,yy3,yy4)
5476 ymine=min(yy1,yy2,yy3,yy4)
5477
5478 zz1=x(3,m1)
5479 zz2=x(3,m2)
5480 zz3=x(3,m3)
5481 zz4=x(3,m4)
5482 zmaxe=max(zz1,zz2,zz3,zz4)
5483 zmine=min(zz1,zz2,zz3,zz4)
5484
5485c index of voxels occupied by the facet
5486
5487 ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
5488 iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
5489 iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
5490
5491 ix1=max(0,min(nbx,ix1))
5492 iy1=max(0,min(nby,iy1))
5493 iz1=max(0,min(nbz,iz1))
5494
5495 ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
5496 iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
5497 iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
5498
5499 ix2=max(0,min(nbx,ix2))
5500 iy2=max(0,min(nby,iy2))
5501 iz2=max(0,min(nbz,iz2))
5502
5503#include "lockon.inc"
5504 DO iz = iz1, iz2
5505 DO iy = iy1, iy2
5506 DO ix = ix1, ix2
5507 crvoxel(iy,iz,loc_proc)=ibset(crvoxel(iy,iz,loc_proc),ix)
5508 END DO
5509 END DO
5510 END DO
5511#include "lockoff.inc"
5512
5513 ENDDO
5514
5515C
5516 RETURN

◆ spmd_tri24gat()

subroutine spmd_tri24gat ( integer result,
integer nsn,
integer, dimension(*) cand_n,
integer i_stok,
integer nin,
integer igap,
integer nsnr,
integer multimp,
integer ity,
integer intth,
integer ilev,
integer iedge4,
type(h3d_database) h3d_data,
integer intfric,
integer intnitsche,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea,
integer, intent(in) nodadt_therm )

Definition at line 2222 of file spmd_int.F.

2226C-----------------------------------------------
2227C M o d u l e s
2228C-----------------------------------------------
2229 USE tri7box
2230 USE message_mod
2231 USE h3d_mod
2232 USE spmd_mod
2233C-----------------------------------------------
2234C I m p l i c i t T y p e s
2235C-----------------------------------------------
2236#include "implicit_f.inc"
2237C-----------------------------------------------
2238C C o m m o n B l o c k s
2239C-----------------------------------------------
2240#include "com01_c.inc"
2241#include "task_c.inc"
2242#include "scr14_c.inc"
2243#include "scr16_c.inc"
2244#include "scr18_c.inc"
2245#include "parit_c.inc"
2246#include "spmd_c.inc"
2247#include "sms_c.inc"
2248C-----------------------------------------------
2249C D u m m y A r g u m e n t s
2250C-----------------------------------------------
2251 INTEGER RESULT, NIN, NSN, I_STOK, IGAP, NSNR, MULTIMP, ITY,
2252 . CAND_N(*),INTTH,ILEV,IEDGE4,INTFRIC,INTNITSCHE
2253 INTEGER , INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
2254 INTEGER , INTENT(IN) :: NODADT_THERM
2255 TYPE(H3D_DATABASE) :: H3D_DATA
2256C-----------------------------------------------
2257C L o c a l V a r i a b l e s
2258C-----------------------------------------------
2259#ifdef MPI
2260 INTEGER OLDNSNR,NODFI,NNP,LSKYFI,
2261 . NOD, LOC_PROC, I, N, NN, P, IDEB, J, K,
2262 . IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,IERROR6,IERROR7,
2263 . IERROR8,IERROR9,IERROR0,IERROR11,IERROR12,
2264 . IERROR13,IERROR14,IERROR15,IERROR16,IERROR17,IERROR18,
2265 . INDEX(NSNR),NN2,RSHIFT,ISHIFT,ND
2266
2267 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX,IAUXINV
2268C-----------------------------------------------
2269C S o u r c e L i n e s
2270C-----------------------------------------------
2271 loc_proc = ispmd + 1
2272C
2273C
2274 nodfi = 0
2275 lskyfi= 0
2276 IF(result==0) THEN
2277C
2278C identification of candidates
2279C
2280 nodfi = 0
2281 DO i = 1, i_stok
2282 n = cand_n(i)
2283 nn = n-nsn
2284 IF(nn>0)THEN
2285 IF(irem(1,nn)>0)THEN
2286 nodfi = nodfi + 1
2287 irem(1,nn) = -irem(1,nn)
2288 ENDIF
2289 ENDIF
2290 ENDDO
2291
2292C E2E Node : Ensure that all E2E IRTS Nodes are retained when
2293C E2E Node is candidate
2294 IF(iedge4 >0)THEN
2295 nn2 = 0
2296 ideb = 0
2297 DO p = 1, nspmd
2298 nn = 0
2299 oldnsnr = nsnfi(nin)%P(p)
2300 DO i = 1, oldnsnr
2301 IF(irem(1,i+ideb)<0 .AND.irem(8,i+ideb)==1 ) THEN
2302C go to where the Secnd surfaces are stored
2303 i24irempnsne = irem(7,i+ideb)
2304
2305 nd = irem(i24irempnsne,i+ideb)
2306
2307 IF (irem(1,nd) >0) THEN
2308 irem(1,nd)=irem(1,nd)*(-1)
2309 nodfi = nodfi + 1
2310 ENDIF
2311
2312 nd = irem(i24irempnsne+1,i+ideb)
2313 IF (irem(1,nd) >0) THEN
2314 irem(1,nd)=irem(1,nd)*(-1)
2315 nodfi = nodfi + 1
2316 ENDIF
2317
2318 nd = irem(i24irempnsne+2,i+ideb)
2319 IF (irem(1,nd) >0) THEN
2320 irem(1,nd)=irem(1,nd)*(-1)
2321 nodfi = nodfi + 1
2322 ENDIF
2323
2324 nd = irem(i24irempnsne+3,i+ideb)
2325 IF (irem(1,nd) >0) THEN
2326 irem(1,nd)=irem(1,nd)*(-1)
2327 nodfi = nodfi + 1
2328 ENDIF
2329
2330 ENDIF
2331
2332 ENDDO
2333 ideb = ideb + oldnsnr
2334 ENDDO
2335
2336 ENDIF
2337
2338cccc DO I = 1, I_STOK
2339cccc N = CAND_N(I)
2340cccc NN = N-NSN
2341cccc IF(NN>0)THEN
2342cccc
2343cccc IF(IREM(1,NN)<0 .AND.IREM(8,NN)==1) THEN
2344cccc I24IREMPNSNE = IREM(7,NN)
2345cccc
2346cccc ND = IREM(I24IREMPNSNE,NN)
2347cccc IF(IREM(1,ND) >0) THEN
2348cccc IREM(1,ND)=IREM(1,ND)*(-1)
2349cccc NODFI = NODFI + 1
2350cccc ENDIF
2351cccc
2352cccc ND = IREM(I24IREMPNSNE+1,NN)
2353cccc IF(IREM(1,ND) >0) THEN
2354cccc IREM(1,ND)=IREM(1,ND)*(-1)
2355cccc NODFI = NODFI + 1
2356cccc ENDIF
2357cccc
2358cccc ND = IREM(I24IREMPNSNE+2,NN)
2359cccc IF(IREM(1,ND) >0) THEN
2360cccc IREM(1,ND)=IREM(1,ND)*(-1)
2361cccc NODFI = NODFI + 1
2362cccccccc ENDIF
2363cccc
2364cccc ND = IREM(I24IREMPNSNE+3,NN)
2365cccc IF(IREM(1,ND) >0) THEN
2366cccc IREM(1,ND)=IREM(1,ND)*(-1)
2367cccc NODFI = NODFI + 1
2368cccc ENDIF
2369cccc ENDIF
2370cccc ENDIF
2371cccc ENDDO
2372cccc ENDIF
2373
2374
2375C
2376C allocation of interface boundary arrays
2377C
2378 ierror1 = 0
2379 ierror2 = 0
2380 ierror3 = 0
2381 ierror4 = 0
2382 ierror5 = 0
2383 ierror6 = 0
2384 ierror7 = 0
2385 ierror8 = 0
2386 ierror9 = 0
2387 ierror0 = 0
2388 ierror11 = 0
2389 ierror12 = 0
2390 ierror13 = 0
2391 ierror14 = 0
2392 ierror15 = 0
2393 ierror16 = 0
2394 ierror17 = 0
2395 ierror18 = 0
2396 IF(ASSOCIATED(nsvfi(nin)%P)) DEALLOCATE(nsvfi(nin)%P)
2397 ALLOCATE(nsvfi(nin)%P(nodfi),stat=ierror1)
2398 IF(ASSOCIATED(xfi(nin)%P)) DEALLOCATE(xfi(nin)%P)
2399 ALLOCATE(xfi(nin)%P(3,nodfi),stat=ierror2)
2400 IF(ASSOCIATED(vfi(nin)%P)) DEALLOCATE(vfi(nin)%P)
2401 ALLOCATE(vfi(nin)%P(3,nodfi),stat=ierror3)
2402 IF(ASSOCIATED(msfi(nin)%P)) DEALLOCATE(msfi(nin)%P)
2403 ALLOCATE(msfi(nin)%P(nodfi),stat=ierror4)
2404 IF(ASSOCIATED(stifi(nin)%P)) DEALLOCATE(stifi(nin)%P)
2405 ALLOCATE(stifi(nin)%P(nodfi),stat=ierror5)
2406 IF(ASSOCIATED(itafi(nin)%P)) DEALLOCATE(itafi(nin)%P)
2407 ALLOCATE(itafi(nin)%P(nodfi),stat=ierror6)
2408 IF(ity==7.OR.ity==22.OR.ity==23.OR.ity==24) THEN
2409 IF(ASSOCIATED(kinfi(nin)%P)) DEALLOCATE(kinfi(nin)%P)
2410 ALLOCATE(kinfi(nin)%P(nodfi),stat=ierror8)
2411 IF(intth > 0 ) THEN
2412 IF(ASSOCIATED(tempfi(nin)%P)) DEALLOCATE(tempfi(nin)%P)
2413 ALLOCATE(tempfi(nin)%P(nodfi),stat=ierror9)
2414 IF(ASSOCIATED(matsfi(nin)%P)) DEALLOCATE(matsfi(nin)%P)
2415 ALLOCATE(matsfi(nin)%P(nodfi),stat=ierror0)
2416 IF(ASSOCIATED(areasfi(nin)%P)) DEALLOCATE(areasfi(nin)%P)
2417 ALLOCATE(areasfi(nin)%P(nodfi),stat=ierror11)
2418 ENDIF
2419 ENDIF
2420 IF(idtmins == 2) THEN
2421 IF(ASSOCIATED(nodnxfi(nin)%P)) DEALLOCATE(nodnxfi(nin)%P)
2422 ALLOCATE(nodnxfi(nin)%P(nodfi),stat=ierror12)
2423 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
2424 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
2425 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
2426 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
2427 IF(ASSOCIATED(t2main_sms_fi(nin)%P)) DEALLOCATE(t2main_sms_fi(nin)%P)
2428 ALLOCATE(t2main_sms_fi(nin)%P(6,nodfi),stat=ierror14)
2429 IF(ASSOCIATED(t2fac_sms_fi(nin)%P)) DEALLOCATE(t2fac_sms_fi(nin)%P)
2430 ALLOCATE(t2fac_sms_fi(nin)%P(nodfi),stat=ierror14)
2431 ELSEIF(idtmins_int /= 0) THEN
2432 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
2433 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
2434 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
2435 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
2436 IF(ASSOCIATED(t2main_sms_fi(nin)%P)) DEALLOCATE(t2main_sms_fi(nin)%P)
2437 ALLOCATE(t2main_sms_fi(nin)%P(6,nodfi),stat=ierror14)
2438 IF(ASSOCIATED(t2fac_sms_fi(nin)%P)) DEALLOCATE(t2fac_sms_fi(nin)%P)
2439 ALLOCATE(t2fac_sms_fi(nin)%P(nodfi),stat=ierror14)
2440 ENDIF
2441 IF(igap/=0) THEN
2442 IF(ASSOCIATED(gapfi(nin)%P)) DEALLOCATE(gapfi(nin)%P)
2443 ALLOCATE(gapfi(nin)%P(nodfi),stat=ierror7)
2444 IF(igap==3) THEN
2445 IF(ASSOCIATED(gap_lfi(nin)%P)) DEALLOCATE(gap_lfi(nin)%P)
2446 ALLOCATE(gap_lfi(nin)%P(nodfi),stat=ierror7)
2447 ENDIF
2448 ENDIF
2449 IF(ity==24)THEN
2450 IF(ASSOCIATED(irtlm_fi(nin)%P)) DEALLOCATE(irtlm_fi(nin)%P)
2451 ALLOCATE(irtlm_fi(nin)%P(2,nodfi),stat=ierror15)
2452
2453 IF(ASSOCIATED(time_sfi(nin)%P)) DEALLOCATE(time_sfi(nin)%P)
2454 ALLOCATE(time_sfi(nin)%P(nodfi),stat=ierror16)
2455
2456 IF(ASSOCIATED(secnd_frfi(nin)%P)) DEALLOCATE(secnd_frfi(nin)%P)
2457 ALLOCATE(secnd_frfi(nin)%P(6,nodfi),stat=ierror16)
2458
2459 IF(ASSOCIATED(pene_oldfi(nin)%P))DEALLOCATE(pene_oldfi(nin)%P)
2460 ALLOCATE(pene_oldfi(nin)%P(5,nodfi),stat=ierror16)
2461
2462 IF(ASSOCIATED(stif_oldfi(nin)%P))DEALLOCATE(stif_oldfi(nin)%P)
2463 ALLOCATE(stif_oldfi(nin)%P(2,nodfi),stat=ierror16)
2464
2465 IF(ASSOCIATED(icont_i_fi(nin)%P))DEALLOCATE(icont_i_fi(nin)%P)
2466 ALLOCATE(icont_i_fi(nin)%P(nodfi),stat=ierror16)
2467
2468 IF(istif_msdt > 0) THEN
2469 IF(ASSOCIATED(stif_msdt_fi(nin)%P))DEALLOCATE(stif_msdt_fi(nin)%P)
2470 ALLOCATE(stif_msdt_fi(nin)%P(nodfi),stat=ierror16)
2471 ENDIF
2472
2473 IF(ifsub_carea > 0) THEN
2474 IF(ASSOCIATED(intareanfi(nin)%P))DEALLOCATE(intareanfi(nin)%P)
2475 ALLOCATE(intareanfi(nin)%P(nodfi),stat=ierror16)
2476 ENDIF
2477
2478C E2E //
2479 IF(ASSOCIATED(isedge_fi(nin)%P))DEALLOCATE(isedge_fi(nin)%P)
2480 ALLOCATE(isedge_fi(nin)%P(nodfi),stat=ierror16)
2481
2482 IF(iedge4 >0)THEN
2483 IF(ASSOCIATED(irtse_fi(nin)%P))DEALLOCATE(irtse_fi(nin)%P)
2484 ALLOCATE(irtse_fi(nin)%P(5,nodfi),stat=ierror16)
2485
2486 IF(ASSOCIATED(is2pt_fi(nin)%P))DEALLOCATE(is2pt_fi(nin)%P)
2487 ALLOCATE(is2pt_fi(nin)%P(nodfi),stat=ierror16)
2488
2489 IF(ASSOCIATED(ispt2_fi(nin)%P))DEALLOCATE(ispt2_fi(nin)%P)
2490 ALLOCATE(ispt2_fi(nin)%P(nodfi),stat=ierror16)
2491
2492 IF(ASSOCIATED(isegpt_fi(nin)%P))DEALLOCATE(isegpt_fi(nin)%P)
2493 ALLOCATE(isegpt_fi(nin)%P(nodfi),stat=ierror16)
2494
2495 IF(ASSOCIATED(is2se_fi(nin)%P))DEALLOCATE(is2se_fi(nin)%P)
2496 ALLOCATE(is2se_fi(nin)%P(2,nodfi),stat=ierror16)
2497
2498 ENDIF
2499
2500 ENDIF
2501 IF(intfric > 0 ) THEN
2502 IF(ASSOCIATED(ipartfricsfi(nin)%P)) DEALLOCATE(ipartfricsfi(nin)%P)
2503 ALLOCATE(ipartfricsfi(nin)%P(nodfi),stat=ierror17)
2504 ENDIF
2505
2506 IF(intnitsche > 0 ) THEN
2507 IF(ASSOCIATED(forneqsfi(nin)%P))DEALLOCATE(forneqsfi(nin)%P)
2508 ALLOCATE(forneqsfi(nin)%P(3,nodfi),stat=ierror18)
2509 ENDIF
2510
2511C
2512 IF(ierror1+ierror2+ierror3+ierror4+ierror5+
2513 + ierror6+ierror7+ierror8 + ierror9 + ierror0 +
2514 + ierror11+ierror12+ierror13+ierror14+ierror15+
2515 + ierror16+ierror17+ierror18 /= 0) THEN
2516 CALL ancmsg(msgid=20,anmode=aninfo)
2517 CALL arret(2)
2518 ENDIF
2519C
2520C compaction of candidates
2521C
2522 ideb = 0
2523 nn2 = 0
2524
2525 DO p = 1, nspmd
2526 nn = 0
2527 oldnsnr = nsnfi(nin)%P(p)
2528
2529 IF(oldnsnr/=0) THEN
2530
2531 ALLOCATE(iaux(oldnsnr),stat=ierror17)
2532 ALLOCATE(iauxinv(oldnsnr),stat=ierror17)
2533 iauxinv(1:oldnsnr)=0
2534 IF(ierror17/=0) THEN
2535 CALL ancmsg(msgid=20,anmode=aninfo)
2536 CALL arret(2)
2537 ENDIF
2538
2539 nnp = nn2
2540
2541 DO i = 1, oldnsnr
2542 IF(irem(1,i+ideb)<0) THEN
2543 nn = nn + 1
2544 iaux(nn) = i
2545 ENDIF
2546 ENDDO
2547
2548c general case
2549#include "vectorize.inc"
2550 DO j = 1, nn
2551 i = iaux(j)
2552 index(i+ideb) = nn2+j
2553 xfi(nin)%P(1,nn2+j) = xrem(1,i+ideb)
2554 xfi(nin)%P(2,nn2+j) = xrem(2,i+ideb)
2555 xfi(nin)%P(3,nn2+j) = xrem(3,i+ideb)
2556 vfi(nin)%P(1,nn2+j) = xrem(4,i+ideb)
2557 vfi(nin)%P(2,nn2+j) = xrem(5,i+ideb)
2558 vfi(nin)%P(3,nn2+j) = xrem(6,i+ideb)
2559 msfi(nin)%P(nn2+j) = xrem(7,i+ideb)
2560 stifi(nin)%P(nn2+j) = xrem(8,i+ideb)
2561 nsvfi(nin)%P(nn2+j) = -irem(1,i+ideb)
2562 itafi(nin)%P(nn2+j) = irem(2,i+ideb)
2563 kinfi(nin)%P(nn2+j) = irem(3,i+ideb)
2564 isedge_fi(nin)%P(nn2+j) = irem(8,i+ideb)
2565 !ignore specifics IREM and XREM indexes for INT24 sorting
2566 !IGAPXREMP = IREM(4,I+IDEB)
2567 !I24XREMP = IREM(5,I+IDEB)
2568 !I24IREMP = IREM(6,I+IDEB)
2569 !I24IREMPNSNE = IREM(7,I+IDEB)
2570 ENDDO
2571
2572c shift for real variables (prepare for next setting)
2573 rshift = 9
2574c shift for integer variables (prepare for next setting)
2575 ishift = 9
2576
2577c IGAP=1 or IGAP=2
2578 IF(igap==1 .OR. igap==2)THEN
2579#include "vectorize.inc"
2580 DO j = 1, nn
2581 i = iaux(j)
2582 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2583 ENDDO
2584 rshift = rshift + 1
2585c IGAP=3
2586 ELSEIF(igap==3)THEN
2587#include "vectorize.inc"
2588 DO j = 1, nn
2589 i = iaux(j)
2590 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2591 gap_lfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
2592 ENDDO
2593 rshift = rshift + 2
2594 ENDIF
2595
2596C thermic
2597 IF(intth>0)THEN
2598#include "vectorize.inc"
2599 DO j = 1, nn
2600 i = iaux(j)
2601 tempfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2602 areasfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
2603 matsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
2604 ENDDO
2605 rshift = rshift + 2
2606 ishift = ishift + 1
2607 ENDIF
2608C Friction model
2609 IF(intfric>0)THEN
2610#include "vectorize.inc"
2611 DO j = 1, nn
2612 i = iaux(j)
2613 ipartfricsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
2614 ENDDO
2615 ishift = ishift + 1
2616 ENDIF
2617
2618C -- IDTMINS==2
2619 IF(idtmins==2)THEN
2620#include "vectorize.inc"
2621 DO j = 1, nn
2622 i = iaux(j)
2623 t2fac_sms_fi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2624 nodnxfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
2625 nodamsfi(nin)%P(nn2+j) = irem(ishift+1,i+ideb)
2626 t2main_sms_fi(nin)%P(1,nn2+j) = irem(ishift+2,i+ideb)
2627 t2main_sms_fi(nin)%P(2,nn2+j) = irem(ishift+3,i+ideb)
2628 t2main_sms_fi(nin)%P(3,nn2+j) = irem(ishift+4,i+ideb)
2629 t2main_sms_fi(nin)%P(4,nn2+j) = irem(ishift+5,i+ideb)
2630 t2main_sms_fi(nin)%P(5,nn2+j) = irem(ishift+6,i+ideb)
2631 t2main_sms_fi(nin)%P(6,nn2+j) = irem(ishift+7,i+ideb)
2632 procamsfi(nin)%P(nn2+j) = p
2633 ENDDO
2634 rshift = rshift + 1
2635 ishift = ishift + 8
2636
2637C -- IDTMINS_INT /= 0
2638 ELSEIF(idtmins_int/=0)THEN
2639#include "vectorize.inc"
2640 DO j = 1, nn
2641 i = iaux(j)
2642 t2fac_sms_fi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2643 nodamsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
2644 t2main_sms_fi(nin)%P(1,nn2+j) = irem(ishift+1,i+ideb)
2645 t2main_sms_fi(nin)%P(2,nn2+j) = irem(ishift+2,i+ideb)
2646 t2main_sms_fi(nin)%P(3,nn2+j) = irem(ishift+3,i+ideb)
2647 t2main_sms_fi(nin)%P(4,nn2+j) = irem(ishift+4,i+ideb)
2648 t2main_sms_fi(nin)%P(5,nn2+j) = irem(ishift+5,i+ideb)
2649 t2main_sms_fi(nin)%P(6,nn2+j) = irem(ishift+6,i+ideb)
2650 procamsfi(nin)%P(nn2+j) = p
2651 ENDDO
2652 rshift = rshift + 1
2653 ishift = ishift + 7
2654 ENDIF
2655
2656c INT24
2657 IF(ity==24)THEN
2658#include "vectorize.inc"
2659 DO j = 1, nn
2660 i = iaux(j)
2661 irtlm_fi(nin)%P(1,nn2+j) =irem(ishift,i+ideb)
2662 irtlm_fi(nin)%P(2,nn2+j) =irem(ishift+1,i+ideb)
2663 icont_i_fi(nin)%P(nn2+j) = irem(ishift+2,i+ideb)
2664 time_sfi(nin)%P(nn2+j ) =xrem(rshift,i+ideb)
2665 secnd_frfi(nin)%P(1,nn2+j) =zero
2666 secnd_frfi(nin)%P(2,nn2+j) =zero
2667 secnd_frfi(nin)%P(3,nn2+j) =zero
2668 secnd_frfi(nin)%P(4,nn2+j) =xrem(rshift+1,i+ideb)
2669 secnd_frfi(nin)%P(5,nn2+j) =xrem(rshift+2,i+ideb)
2670 secnd_frfi(nin)%P(6,nn2+j) =xrem(rshift+3,i+ideb)
2671 pene_oldfi(nin)%P(1,nn2+j)=zero
2672 stif_oldfi(nin)%P(1,nn2+j)=zero
2673 pene_oldfi(nin)%P(2,nn2+j)=xrem(rshift+4,i+ideb)
2674 stif_oldfi(nin)%P(2,nn2+j)=xrem(rshift+5,i+ideb)
2675C
2676C We Store PENE_OLD(3 in PENE_OLD(4 during sorting
2677 pene_oldfi(nin)%P(4,nn2+j)=xrem(rshift+6,i+ideb)
2678 pene_oldfi(nin)%P(5,nn2+j)=xrem(rshift+7,i+ideb)
2679 ENDDO
2680 rshift = rshift + 8
2681
2682C Stif based on mass and dt
2683
2684 IF(istif_msdt > 0) THEN
2685#include "vectorize.inc"
2686 DO j = 1, nn
2687 i = iaux(j)
2688 stif_msdt_fi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2689 ENDDO
2690 rshift = rshift + 1
2691 ENDIF
2692
2693C CAREA output
2694
2695 IF(ifsub_carea > 0) THEN
2696#include "vectorize.inc"
2697 DO j = 1, nn
2698 i = iaux(j)
2699 intareanfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
2700 ENDDO
2701 rshift = rshift + 1
2702 ENDIF
2703
2704 ishift = ishift + 3
2705 IF (ilev==2) ishift = ishift + 1
2706
2707 IF (iedge4 > 0)THEN
2708 DO j = 1, nn
2709 i = iaux(j)
2710 IF( irem(8,i+ideb)==1)THEN
2711 nd = irem(ishift,i+ideb)
2712
2713 irtse_fi(nin)%P(1,nn2+j) = index(nd)
2714 nd = irem(ishift+1,i+ideb)
2715 irtse_fi(nin)%P(2,nn2+j) = index(nd)
2716
2717 nd = irem(ishift+2,i+ideb)
2718 irtse_fi(nin)%P(3,nn2+j) = index(nd)
2719
2720 nd = irem(ishift+3,i+ideb)
2721 irtse_fi(nin)%P(4,nn2+j) = index(nd)
2722
2723 irtse_fi(nin)%P(5,nn2+j) = irem(ishift+4,i+ideb)
2724
2725 is2pt_fi(nin)%P(nn2+j) = irem(ishift+5,i+ideb)
2726 ispt2_fi(nin)%P(nn2+j) = irem(ishift+7,i+ideb)
2727 is2se_fi(nin)%P(1,nn2+j) = nn2+j
2728 is2se_fi(nin)%P(2,nn2+j) = 0
2729 ELSE
2730 irtse_fi(nin)%P(1:5,nn2+j) = 0
2731 is2pt_fi(nin)%P(nn2+j) = 0
2732 isegpt_fi(nin)%P(nn2+j) = 0
2733 is2se_fi(nin)%P(1,nn2+j) =0
2734 is2se_fi(nin)%P(2,nn2+j) = 0
2735 ispt2_fi(nin)%P(nn2+j) = irem(ishift+7,i+ideb)
2736 ENDIF
2737 IF(irem(ishift+6,i+ideb) > 0)THEN
2738c ND = IREM(ISHIFT+6,I+IDEB)
2739C ISEGPT_FI(NIN)%P(NN2+J)= IAUXINV(ND)
2740 isegpt_fi(nin)%P(nn2+j)= 0
2741 ELSE
2742 isegpt_fi(nin)%P(nn2+j)= 0
2743 ENDIF
2744 ENDDO
2745 ishift = ishift + 8
2746 ENDIF
2747 ENDIF
2748
2749C NITSCHE
2750
2751 IF(intnitsche > 0 ) THEN
2752
2753#include "vectorize.inc"
2754 DO j = 1, nn
2755 i = iaux(j)
2756 forneqsfi(nin)%P(1,nn2+j) = xrem(rshift,i+ideb)
2757 forneqsfi(nin)%P(2,nn2+j) = xrem(rshift+1,i+ideb)
2758 forneqsfi(nin)%P(3,nn2+j) = xrem(rshift+2,i+ideb)
2759 ENDDO
2760 rshift = rshift + 3
2761
2762 ENDIF
2763
2764 nn2 = nn2 + nn
2765 ideb = ideb + oldnsnr
2766 nsnfi(nin)%P(p) = nn2-nnp
2767
2768 DEALLOCATE(iaux)
2769 DEALLOCATE(iauxinv)
2770
2771 ENDIF !IF(OLDNSNR/=0)
2772
2773 ENDDO ! end do NSPMD
2774
2775 lskyfi = nn2*multimax
2776C NSNR New useful for inactive
2777 nsnr = nn2
2778 ENDIF
2779C
2780C deallocation of XREM IREM
2781C
2782 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
2783 IF(ALLOCATED(irem)) DEALLOCATE(irem)
2784
2785C
2786 ierror1=0
2787 ierror2=0
2788 ierror3=0
2789 ierror4=0
2790 IF(intth == 0 ) THEN
2791C
2792C Allocation Parith/OFF
2793C
2794 IF(iparit==0) THEN
2795
2796 IF(ASSOCIATED(afi(nin)%P)) THEN
2797 DEALLOCATE(afi(nin)%P)
2798 NULLIFY(afi(nin)%P)
2799 ENDIF
2800 IF(ASSOCIATED(stnfi(nin)%P)) THEN
2801 DEALLOCATE(stnfi(nin)%P)
2802 NULLIFY(afi(nin)%P)
2803 ENDIF
2804
2805 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
2806 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
2807C Init a 0
2808 DO i = 1, nodfi*nthread
2809 afi(nin)%P(1,i) = zero
2810 afi(nin)%P(2,i) = zero
2811 afi(nin)%P(3,i) = zero
2812 stnfi(nin)%P(i) = zero
2813 ENDDO
2814C
2815 IF(kdtint/=0)THEN
2816 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
2817 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
2818C Init a 0
2819 DO i = 1, nodfi*nthread
2820 vscfi(nin)%P(i) = zero
2821 ENDDO
2822 ENDIF
2823 nlskyfi(nin) = nodfi
2824C
2825 ELSE
2826C
2827C Allocation Parith/ON
2828C
2829 IF(ASSOCIATED(fskyfi(nin)%P)) DEALLOCATE(fskyfi(nin)%P)
2830 IF(ASSOCIATED(iskyfi(nin)%P)) DEALLOCATE(iskyfi(nin)%P)
2831 nlskyfi(nin) = lskyfi
2832 IF(lskyfi>0) THEN
2833 ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror1)
2834 IF(kdtint==0) THEN
2835 ALLOCATE(fskyfi(nin)%P(4,lskyfi),stat=ierror2)
2836 ELSE
2837 ALLOCATE(fskyfi(nin)%P(5,lskyfi),stat=ierror2)
2838 ENDIF
2839 ENDIF
2840 ENDIF
2841 ELSE
2842C
2843C Allocation Parith/OFF
2844C
2845 IF(iparit==0) THEN
2846 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
2847 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
2848 IF(ASSOCIATED(fthefi(nin)%P)) DEALLOCATE(fthefi(nin)%P)
2849 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
2850 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
2851 IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror3)
2852C
2853 IF(nodadt_therm ==1) THEN
2854 IF(ASSOCIATED(condnfi(nin)%P)) DEALLOCATE(condnfi(nin)%P)
2855 IF(nodfi>0.AND.nodadt_therm ==1)ALLOCATE(condnfi(nin)%P(nodfi*nthread),stat=ierror4)
2856 ENDIF
2857C
2858
2859
2860C Init a 0
2861
2862 DO i = 1, nodfi*nthread
2863 afi(nin)%P(1,i) = zero
2864 afi(nin)%P(2,i) = zero
2865 afi(nin)%P(3,i) = zero
2866 stnfi(nin)%P(i) = zero
2867 fthefi(nin)%P(i) = zero
2868 ENDDO
2869 IF(nodadt_therm ==1) THEN
2870 DO i = 1, nodfi
2871 condnfi(nin)%P(i) = zero
2872 ENDDO
2873 ENDIF
2874C
2875 IF(kdtint/=0)THEN
2876 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
2877 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi),stat=ierror4)
2878C Init a 0
2879 DO i = 1, nodfi
2880 vscfi(nin)%P(i) = zero
2881 ENDDO
2882 ENDIF
2883C
2884 ELSE
2885C
2886C Allocation Parith/ON
2887C
2888 IF(ASSOCIATED(fskyfi(nin)%P)) DEALLOCATE(fskyfi(nin)%P)
2889 IF(ASSOCIATED(iskyfi(nin)%P)) DEALLOCATE(iskyfi(nin)%P)
2890 IF(ASSOCIATED(ftheskyfi(nin)%P)) DEALLOCATE(ftheskyfi(nin)%P)
2891 nlskyfi(nin) = lskyfi
2892 IF(lskyfi>0) THEN
2893 ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror1)
2894 IF(kdtint==0) THEN
2895 ALLOCATE(fskyfi(nin)%P(4,lskyfi),stat=ierror2)
2896 ALLOCATE(ftheskyfi(nin)%P(lskyfi),stat=ierror3)
2897 ELSE
2898 ALLOCATE(fskyfi(nin)%P(5,lskyfi),stat=ierror2)
2899 ALLOCATE(ftheskyfi(nin)%P(lskyfi),stat=ierror3)
2900 ENDIF
2901
2902 ENDIF
2903C
2904 IF(nodadt_therm ==1) THEN
2905 IF(ASSOCIATED(condnskyfi(nin)%P)) DEALLOCATE(condnskyfi(nin)%P)
2906 IF(lskyfi>0) ALLOCATE(condnskyfi(nin)%P(lskyfi),stat=ierror4)
2907 ENDIF
2908C
2909
2910 ENDIF
2911 ENDIF
2912C
2913 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
2914 CALL ancmsg(msgid=20,anmode=aninfo)
2915 CALL arret(2)
2916 ENDIF
2917C
2918C Output Pressure / Friction Energy conditional allowances
2919C
2920 IF(anim_v(12)+outp_v(12)+h3d_data%N_VECT_PCONT >0)THEN
2921 IF(ASSOCIATED(fnconti(nin)%P)) DEALLOCATE(fnconti(nin)%P)
2922 IF(ASSOCIATED(ftconti(nin)%P)) DEALLOCATE(ftconti(nin)%P)
2923 ALLOCATE(fnconti(nin)%P(3,nodfi),stat=ierror1)
2924 ALLOCATE(ftconti(nin)%P(3,nodfi),stat=ierror2)
2925 IF(ierror1+ierror2/=0) THEN
2926 CALL ancmsg(msgid=20,anmode=aninfo)
2927 CALL arret(2)
2928 ELSE
2929 DO j = 1, nodfi
2930 fnconti(nin)%P(1,j)=zero
2931 fnconti(nin)%P(2,j)=zero
2932 fnconti(nin)%P(3,j)=zero
2933 ftconti(nin)%P(1,j)=zero
2934 ftconti(nin)%P(2,j)=zero
2935 ftconti(nin)%P(3,j)=zero
2936 END DO
2937 END IF
2938 END IF
2939
2940 IF(h3d_data%N_SCAL_CSE_FRICINT >0)THEN
2941 IF(h3d_data%N_CSE_FRIC_INTER (nin) >0)THEN
2942 IF(ASSOCIATED(efricfi(nin)%P)) DEALLOCATE(efricfi(nin)%P)
2943 ALLOCATE(efricfi(nin)%P(nodfi),stat=ierror1)
2944 IF(ierror1/=0) THEN
2945 CALL ancmsg(msgid=20,anmode=aninfo)
2946 CALL arret(2)
2947 ELSE
2948 DO j = 1, nodfi
2949 efricfi(nin)%P(j)=zero
2950 END DO
2951 END IF
2952 END IF
2953 ENDIF
2954 IF(h3d_data%N_SCAL_CSE_FRIC >0)THEN
2955 IF(ASSOCIATED(efricgfi(nin)%P)) DEALLOCATE(efricgfi(nin)%P)
2956 ALLOCATE(efricgfi(nin)%P(nodfi),stat=ierror1)
2957 IF(ierror1/=0) THEN
2958 CALL ancmsg(msgid=20,anmode=aninfo)
2959 CALL arret(2)
2960 ELSE
2961 DO j = 1, nodfi
2962 efricgfi(nin)%P(j)=zero
2963 END DO
2964 END IF
2965 END IF
2966C
2967C
2968C renumbering of candidates
2969C
2970 DO i = 1, i_stok
2971 n = cand_n(i)
2972 nn = n-nsn
2973 IF(nn>0)THEN
2974 cand_n(i) = index(nn)+nsn
2975 ENDIF
2976 ENDDO
2977C
2978#endif
2979 RETURN
tri7box::ispt2_fi
type(int_pointer), dimension(:), allocatable ispt2_fi
Definition tri7box.F:538
tri7box::stif_oldfi
type(real_pointer2), dimension(:), allocatable stif_oldfi
Definition tri7box.F:545
tri7box::secnd_frfi
type(real_pointer2), dimension(:), allocatable secnd_frfi
Definition tri7box.F:543
tri7box::stif_msdt_fi
type(real_pointer), dimension(:), allocatable stif_msdt_fi
Definition tri7box.F:552
tri7box::is2pt_fi
type(int_pointer), dimension(:), allocatable is2pt_fi
Definition tri7box.F:537
tri7box::ftheskyfi
type(real_pointer), dimension(:), allocatable ftheskyfi
Definition tri7box.F:449
tri7box::isegpt_fi
type(int_pointer), dimension(:), allocatable isegpt_fi
Definition tri7box.F:539
tri7box::forneqsfi
type(real_pointer2), dimension(:), allocatable forneqsfi
Definition tri7box.F:459
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::is2se_fi
type(int_pointer2), dimension(:), allocatable is2se_fi
Definition tri7box.F:536
tri7box::efricgfi
type(real_pointer), dimension(:), allocatable efricgfi
Definition tri7box.F:511
tri7box::i24irempnsne
integer i24irempnsne
Definition tri7box.F:423
tri7box::condnskyfi
type(real_pointer), dimension(:), allocatable condnskyfi
Definition tri7box.F:449
tri7box::irtse_fi
type(int_pointer2), dimension(:), allocatable irtse_fi
Definition tri7box.F:535
tri7box::intareanfi
type(real_pointer), dimension(:), allocatable intareanfi
Definition tri7box.F:554
tri7box::isedge_fi
type(int_pointer), dimension(:), allocatable isedge_fi
Definition tri7box.F:540
tri7box::efricfi
type(real_pointer), dimension(:), allocatable efricfi
Definition tri7box.F:511
tri7box::t2fac_sms_fi
type(real_pointer), dimension(:), allocatable t2fac_sms_fi
Definition tri7box.F:557
tri7box::kinfi
type(int_pointer), dimension(:), allocatable kinfi
Definition tri7box.F:440
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::icont_i_fi
type(int_pointer), dimension(:), allocatable icont_i_fi
Definition tri7box.F:532
tri7box::t2main_sms_fi
type(int_pointer2), dimension(:), allocatable t2main_sms_fi
Definition tri7box.F:558

◆ spmd_tri24vox()

subroutine spmd_tri24vox ( integer, dimension(*) nsv,
integer nsn,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifn,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nsnr,
integer igap,
gap_s,
integer, dimension(*) itab,
integer, dimension(*) kinet,
integer ifq,
integer inacti,
integer, dimension(*) nsnfiold,
integer intth,
integer, dimension(*) ielec,
areas,
temp,
integer num_imp,
integer, dimension(*) nodnx_sms,
gap_s_l,
integer ityp,
integer, dimension(2,*) i24_irtlm,
i24_time_s,
i24_frfi,
i24_pene_old,
i24_stif_old,
integer, dimension(*) nbinflg,
integer ilev,
integer, dimension(*) i24_icont_i,
xfic,
vfic,
integer iedge4,
integer nsne,
integer, dimension(2,*) is2se,
integer, dimension(5,*) irtse,
integer, dimension(*) is2pt,
integer, dimension(*) isegpt,
msfic,
integer nrtse,
integer, dimension(*) is2id,
integer, dimension(*) ispt2,
integer intfric,
integer, dimension(*) ipartfrics,
integer, dimension(6,*) t2main_sms,
integer intnitsche,
forneqs,
t2fac_sms,
integer, intent(in) istif_msdt,
dimension(nsn), intent(in) stifmsdt_s,
integer, intent(in) ifsub_carea,
dimension(numnod), intent(in) intarean )

Definition at line 1383 of file spmd_int.F.

1396C-----------------------------------------------
1397C M o d u l e s
1398C-----------------------------------------------
1399 USE tri7box
1400 USE message_mod
1401 USE spmd_mod
1402C-----------------------------------------------
1403C I m p l i c i t T y p e s
1404C-----------------------------------------------
1405#include "implicit_f.inc"
1406C-----------------------------------------------
1407C C o m m o n B l o c k s
1408C-----------------------------------------------
1409#include "com01_c.inc"
1410#include "com04_c.inc"
1411#include "task_c.inc"
1412#include "timeri_c.inc"
1413#include "sms_c.inc"
1414C-----------------------------------------------
1415C D u m m y A r g u m e n t s
1416C-----------------------------------------------
1417 INTEGER NIN, NSN, IFQ, INACTI, IGAP,INTTH,INTFRIC,INTNITSCHE,
1418 . NSNFIOLD(*), NSV(*), WEIGHT(*),
1419 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
1420 . IAD_ELEM(2,*), FR_ELEM(*), ITAB(*), KINET(*),
1421 . IELEC(*),NUM_IMP, NODNX_SMS(*),I24_IRTLM(2,*),ITYP,
1422 . NBINFLG(*),ILEV,I24_ICONT_I(*),IEDGE4,NSNE,IS2SE(2,*),IRTSE(5,*),
1423 . IS2PT(*),ISEGPT(*),NRTSE, NSNR,IS2ID(*),ISPT2(*),IPARTFRICS(*),T2MAIN_SMS(6,*)
1424 INTEGER , INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
1425
1426 my_real
1427 . x(3,*), v(3,*), ms(*), bminmal(*), stifn(*), gap_s(*),
1428 . areas(*),temp(*),gap_s_l(*),i24_time_s(*),i24_frfi(6,*),
1429 . i24_pene_old(5,*),i24_stif_old(2,*),xfic(3,*),vfic(3,*),msfic(*),
1430 . forneqs(3,*),t2fac_sms(*)
1431 my_real , INTENT(IN) :: stifmsdt_s(nsn) , intarean(numnod)
1432C-----------------------------------------------
1433C L o c a l V a r i a b l e s
1434C-----------------------------------------------
1435#ifdef MPI
1436 INTEGER MSGTYP, I, NOD, LOC_PROC, P, IDEB,
1437 . SIZ,J, L, BUFSIZ, LEN, NB, IERROR1, IAD,
1438 . IERROR,REQ_SB(NSPMD),
1439 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
1440 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
1441 . REQ_RC(NSPMD),REQ_SC(NSPMD),
1442 . INDEXI,ISINDEXI(NSPMD),INDEX(NUMNOD+NSNE),NBOX(NSPMD),
1443 . NBX,NBY,NBZ,IX,IY,IZ,
1444 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5,
1445 . RSIZ, ISIZ, L2, REQ_SD3(NSPMD),REQ_RD2(NSPMD),
1446 . LEN2, RSHIFT, ISHIFT,BOXR,NBE,ND,SURF,N1,N2,N3,N4,
1447 . SE,N
1448
1449 DATA msgoff/6016/
1450 DATA msgoff2/6017/
1451 DATA msgoff3/6018/
1452 DATA msgoff4/6019/
1453 DATA msgoff5/6020/
1454
1455 my_real
1456 . bminma(6,nspmd),
1457 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb
1458
1459 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
1460 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
1461
1462 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG_SN,INDEXE,TAG_2RY,NSV_INV
1463C-----------------------------------------------
1464C S o u r c e L i n e s
1465C-----------------------------------------------
1466C
1467 IF(iedge4 /=0)THEN
1468 ALLOCATE(tag_sn(numnod))
1469 ALLOCATE(indexe(numnod+nsne))
1470 ALLOCATE(tag_2ry(nsn))
1471 ALLOCATE(nsv_inv(numnod))
1472 ELSE
1473 ALLOCATE(tag_sn(0))
1474 ALLOCATE(indexe(0))
1475 ALLOCATE(tag_2ry(0))
1476 ALLOCATE(nsv_inv(0))
1477 ENDIF
1478C=======================================================================
1479C tag of the boxes containing facets
1480C and creation of candidates
1481C=======================================================================
1482 loc_proc = ispmd + 1
1483
1484 nbx = lrvoxel
1485 nby = lrvoxel
1486 nbz = lrvoxel
1487C
1488C Old value backup of the NSN Frontieres
1489C
1490 IF(inacti==5.OR.inacti==6.OR.inacti==7.OR.ifq>0
1491 . .OR.num_imp>0.OR.ityp==23.OR.ityp==24) THEN
1492 DO p = 1, nspmd
1493 nsnfiold(p) = nsnfi(nin)%P(p)
1494 END DO
1495 END IF
1496C
1497C minmax box for sorting coming from i7buce BMINMA
1498C
1499 IF(ircvfrom(nin,loc_proc)==0.AND.
1500 . isendto(nin,loc_proc)==0) RETURN
1501 bminma(1,loc_proc) = bminmal(1)
1502 bminma(2,loc_proc) = bminmal(2)
1503 bminma(3,loc_proc) = bminmal(3)
1504 bminma(4,loc_proc) = bminmal(4)
1505 bminma(5,loc_proc) = bminmal(5)
1506 bminma(6,loc_proc) = bminmal(6)
1507C
1508C Voxel shipment + min/max box
1509C
1510 IF(ircvfrom(nin,loc_proc)/=0) THEN
1511 DO p = 1, nspmd
1512 IF(isendto(nin,p)/=0) THEN
1513
1514
1515
1516 IF(p/=loc_proc) THEN
1517 msgtyp = msgoff
1518 CALL spmd_isend(
1519 . crvoxel(0,0,loc_proc),
1520 . (lrvoxel+1)*(lrvoxel+1),
1521 .
1522 . it_spmd(p),msgtyp,req_sc(p))
1523 msgtyp = msgoff2
1524 CALL spmd_isend(
1525 . bminma(1,loc_proc),6 ,it_spmd(p),msgtyp,
1526 . req_sb(p))
1527 ENDIF
1528 ENDIF
1529 ENDDO
1530 ENDIF
1531C
1532C Voxel reception + min-max boxes
1533C
1534 IF(isendto(nin,loc_proc)/=0) THEN
1535 nbirecv=0
1536 DO p = 1, nspmd
1537 IF(ircvfrom(nin,p)/=0) THEN
1538 IF(loc_proc/=p) THEN
1539 nbirecv=nbirecv+1
1540 irindexi(nbirecv)=p
1541 msgtyp = msgoff
1542 CALL spmd_irecv(
1543 . crvoxel(0,0,p),
1544 . (lrvoxel+1)*(lrvoxel+1),
1545 .
1546 . it_spmd(p),msgtyp,req_rc(nbirecv))
1547 msgtyp = msgoff2
1548 CALL spmd_irecv(
1549 . bminma(1,p) ,6 ,it_spmd(p),msgtyp,
1550 . req_rb(nbirecv))
1551 ENDIF
1552 ENDIF
1553 ENDDO
1554 ENDIF
1555C
1556C sending XREM
1557C
1558C computation of real and integer sending buffers sizes
1559c general case
1560 rsiz = 8
1561 isiz = 8
1562
1563c specific cases
1564c IGAP=1 or IGAP=2
1565 IF(igap==1 .OR. igap==2)THEN
1566 rsiz = rsiz + 1
1567c IGAP=3
1568 ELSEIF(igap==3)THEN
1569 rsiz = rsiz + 2
1570 ENDIF
1571
1572C thermic
1573 IF(intth > 0 ) THEN
1574 rsiz = rsiz + 2
1575 isiz = isiz + 1
1576 ENDIF
1577C Friction
1578 IF(intfric > 0 ) THEN
1579 isiz = isiz + 1
1580 ENDIF
1581
1582C -- IDTMINS==2
1583 IF(idtmins == 2)THEN
1584 rsiz = rsiz + 1
1585 isiz = isiz + 8
1586C -- IDTMINS_INT /= 0
1587 ELSEIF(idtmins_int/=0)THEN
1588 rsiz = rsiz + 1
1589 isiz = isiz + 7
1590 END IF
1591
1592c INT24
1593 IF(ityp==24)THEN
1594 rsiz = rsiz + 8
1595 isiz = isiz + 3
1596C-----for NBINFLG
1597 IF (ilev==2) isiz = isiz + 1
1598 IF(iedge4 > 0)isiz = isiz + 8
1599 ENDIF
1600C
1601C---Nitsche
1602 IF(intnitsche > 0) rsiz = rsiz + 3
1603C
1604C---Stiffness based on mass and time step
1605 IF(istif_msdt > 0) rsiz = rsiz + 1
1606
1607C--- Carea output
1608 IF(ifsub_carea > 0) rsiz = rsiz + 1
1609
1610 ideb = 1
1611
1612 IF(isendto(nin,loc_proc)/=0) THEN
1613 DO kk = 1, nbirecv
1614 CALL spmd_waitany(nbirecv,req_rb,indexi)
1615 p=irindexi(indexi)
1616 CALL spmd_wait(req_rc(indexi))
1617C Special treatment on d.d. keep only internal nodes
1618 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
1619 nod = fr_elem(j)
1620C weight < 0 temporarily to keep only non-border nodes
1621 weight(nod) = weight(nod)*(-1)
1622 ENDDO
1623C
1624 IF(iedge4 /=0)THEN
1625 tag_sn(1:numnod)=0
1626 tag_2ry(1:nsn)=0
1627 ENDIF
1628
1629 l = ideb
1630 nbox(p) = 0
1631 nb = 0
1632 xmaxb = bminma(1,p)
1633 ymaxb = bminma(2,p)
1634 zmaxb = bminma(3,p)
1635 xminb = bminma(4,p)
1636 yminb = bminma(5,p)
1637 zminb = bminma(6,p)
1638 DO i=1,nsn-nsne
1639 nod = nsv(i)
1640 IF(iedge4 >0)THEN
1641C Need an inverted NSV to add some Edge Nodes
1642 nsv_inv(nod)=i
1643 ENDIF
1644 IF (nod <= numnod)THEN
1645 IF(weight(nod)==1)THEN
1646 IF(stifn(i)>zero)THEN
1647 IF(x(1,nod) < xminb) cycle
1648 IF(x(1,nod) > xmaxb) cycle
1649 IF(x(2,nod) < yminb) cycle
1650 IF(x(2,nod) > ymaxb) cycle
1651 IF(x(3,nod) < zminb) cycle
1652 IF(x(3,nod) > zmaxb) cycle
1653
1654
1655 ix=int(nbx*(x(1,nod)-xminb)/(xmaxb-xminb))
1656 IF(ix >= 0 .AND. ix <= nbx) THEN
1657 iy=int(nby*(x(2,nod)-yminb)/(ymaxb-yminb))
1658 IF(iy >= 0 .AND. iy <= nby) THEN
1659 iz=int(nbz*(x(3,nod)-zminb)/(zmaxb-zminb))
1660 IF(iz >= 0 .AND. iz <= nbz) THEN
1661 IF(btest(crvoxel(iy,iz,p),ix)) THEN
1662 nb = nb + 1
1663 index(nb) = i
1664 IF(iedge4>0) THEN
1665 tag_sn(nod)=nb
1666 tag_2ry(i)=nb
1667 ENDIF
1668 ENDIF
1669 ENDIF
1670 ENDIF
1671 ENDIF
1672 ENDIF
1673 ENDIF
1674 ENDIF
1675 ENDDO
1676
1677 nbe = 0
1678 DO i=nsn-nsne+1,nsn
1679 nod = nsv(i)
1680 IF(stifn(i)>zero)THEN
1681 nd = nod-numnod
1682 IF(xfic(1,nd) < xminb) cycle
1683 IF(xfic(1,nd) > xmaxb) cycle
1684 IF(xfic(2,nd) < yminb) cycle
1685 IF(xfic(2,nd) > ymaxb) cycle
1686 IF(xfic(3,nd) < zminb) cycle
1687 IF(xfic(3,nd) > zmaxb) cycle
1688
1689 ix=int(nbx*(xfic(1,nd)-xminb)/(xmaxb-xminb))
1690 IF(ix >= 0 .AND. ix <= nbx) THEN
1691 iy=int(nby*(xfic(2,nd)-yminb)/(ymaxb-yminb))
1692 IF(iy >= 0 .AND. iy <= nby) THEN
1693 iz=int(nbz*(xfic(3,nd)-zminb)/(zmaxb-zminb))
1694 IF(iz >= 0 .AND. iz <= nbz) THEN
1695 IF(btest(crvoxel(iy,iz,p),ix)) THEN
1696 nbe = nbe + 1
1697 indexe(nbe) = i
1698 surf=is2se(1,nd)
1699
1700 n1 = irtse(1,surf)
1701 IF( tag_sn(n1)==0)THEN
1702 nb = nb + 1
1703 index(nb) = nsv_inv(n1)
1704 tag_sn(n1)=-nb ! Tag SN is tagged negatively - this will set ISEDGE_FI to -1
1705 ENDIF ! in order to remove it from sorting.
1706 n2 = irtse(2,surf)
1707 IF( tag_sn(n2)==0)THEN
1708 nb = nb + 1
1709 index(nb) = nsv_inv(n2)
1710 tag_sn(n2)=-nb
1711 ENDIF
1712 n3 = irtse(3,surf)
1713 IF( tag_sn(n3)==0)THEN
1714 nb = nb + 1
1715 index(nb) = nsv_inv(n3)
1716 tag_sn(n3)=-nb
1717 ENDIF
1718 n4 = irtse(4,surf)
1719 IF( tag_sn(n4)==0)THEN
1720 nb = nb + 1
1721 index(nb) = nsv_inv(n4)
1722 tag_sn(n4)=-nb
1723 ENDIF
1724 ENDIF
1725 ENDIF
1726 ENDIF
1727 ENDIF
1728 ENDIF ! IF(STIFN(I)>ZERO)THEN
1729
1730 ENDDO
1731C Have the E2E Fictive node at the end
1732 DO i=1,nbe
1733 nb = nb + 1
1734 index(nb) = indexe(i)
1735 tag_2ry(indexe(i))=nb
1736 ENDDO
1737C
1738 nbox(p) = nb
1739
1740 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
1741 nod = fr_elem(j)
1742C resumption of weight > 0
1743 weight(nod) = weight(nod)*(-1)
1744 ENDDO
1745C
1746C Envoi taille msg
1747C
1748 msgtyp = msgoff3
1749 CALL spmd_isend(nbox(p),1,it_spmd(p),msgtyp,
1750 . req_sd(p))
1751C
1752C Alloc buffer
1753C
1754 IF (nb>0) THEN
1755 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
1756 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
1757 IF(ierror/=0) THEN
1758 CALL ancmsg(msgid=20,anmode=aninfo)
1759 CALL arret(2)
1760 ENDIF
1761 l = 0
1762 l2= 0
1763
1764c general case
1765 DO j = 1, nb
1766 i = index(j)
1767 nod = nsv(i)
1768 IF(nod <=numnod)THEN
1769 rbuf(p)%p(l+1) = x(1,nod)
1770 rbuf(p)%p(l+2) = x(2,nod)
1771 rbuf(p)%p(l+3) = x(3,nod)
1772 rbuf(p)%p(l+4) = v(1,nod)
1773 rbuf(p)%p(l+5) = v(2,nod)
1774 rbuf(p)%p(l+6) = v(3,nod)
1775 rbuf(p)%p(l+7) = ms(nod)
1776 rbuf(p)%p(l+8) = stifn(i)
1777 ibuf(p)%p(l2+1) = i
1778 ibuf(p)%p(l2+2) = itab(nod)
1779 ibuf(p)%p(l2+3) = kinet(nod)
1780 IF(iedge4 >0)THEN
1781C Local Node : 0, local sleeping node : -1 or E2E Node : 1
1782C Local sleeping nodes are nodes which are not candidated but stays
1783C in E2E IRTS Secnd surface. They must be shipped, but removed from sorting
1784C IBUF(8,ND) ->ISEDGE_FI
1785 IF(tag_sn(nod)<0)THEN
1786 ibuf(p)%p(l2+8) = -1
1787 ELSE
1788 ibuf(p)%p(l2+8) = 0
1789 ENDIF
1790 ELSE
1791 ibuf(p)%p(l2+8) = 0
1792 ENDIF
1793 ELSE
1794 nd=nod-numnod
1795 rbuf(p)%p(l+1) = xfic(1,nd)
1796 rbuf(p)%p(l+2) = xfic(2,nd)
1797 rbuf(p)%p(l+3) = xfic(3,nd)
1798 rbuf(p)%p(l+4) = vfic(1,nd)
1799 rbuf(p)%p(l+5) = vfic(2,nd)
1800 rbuf(p)%p(l+6) = vfic(3,nd)
1801 rbuf(p)%p(l+7) = msfic(nd)
1802 rbuf(p)%p(l+8) = stifn(i)
1803 ibuf(p)%p(l2+1) = i
1804 ibuf(p)%p(l2+2) = is2id(nd)
1805 ibuf(p)%p(l2+3) = 0
1806C Local Node : 0, local sleeping node : -1 or E2E Node : 1
1807 ibuf(p)%p(l2+8) = 1
1808 ENDIF
1809 !save specifics IREM and XREM indexes for INT24 sorting
1810 ibuf(p)%p(l2+4) = 0 !IGAPXREMP
1811 ibuf(p)%p(l2+5) = 0 !I24XREMP
1812 ibuf(p)%p(l2+6) = 0 !I24IREMP
1813 ibuf(p)%p(l2+7) = 0 !I24IREMPNSNE
1814 l = l + rsiz
1815 l2 = l2 + isiz
1816 END DO
1817
1818c shift for real variables (prepare for next setting)
1819 rshift = 9
1820c shift for integer variables (prepare for next setting)
1821 ishift = 9
1822
1823c specific cases
1824c IGAP=1 or IGAP=2
1825 IF(igap==1 .OR. igap==2)THEN
1826 l = 0
1827 igapxremp = rshift
1828 DO j = 1, nb
1829 i = index(j)
1830 rbuf(p)%p(l+rshift)= gap_s(i)
1831 l = l + rsiz
1832 ENDDO
1833 rshift = rshift + 1
1834
1835c IGAP=3
1836 ELSEIF(igap==3)THEN
1837 l = 0
1838 igapxremp = rshift
1839 DO j = 1, nb
1840 i = index(j)
1841 rbuf(p)%p(l+rshift) = gap_s(i)
1842 rbuf(p)%p(l+rshift+1)= gap_s_l(i)
1843 l = l + rsiz
1844 END DO
1845 rshift = rshift + 2
1846 ENDIF
1847
1848C thermic
1849 IF(intth>0)THEN
1850 l = 0
1851 l2 = 0
1852 DO j = 1, nb
1853 i = index(j)
1854 nod = nsv(i)
1855 rbuf(p)%p(l+rshift) = temp(nod)
1856 rbuf(p)%p(l+rshift+1) = areas(i)
1857 ibuf(p)%p(l2+ishift) = ielec(i)
1858 l = l + rsiz
1859 l2 = l2 + isiz
1860 END DO
1861 rshift = rshift + 2
1862 ishift = ishift + 1
1863 ENDIF
1864C Friction
1865 IF(intfric>0)THEN
1866 l2 = 0
1867 DO j = 1, nb
1868 i = index(j)
1869 ibuf(p)%p(l2+ishift) = ipartfrics(i)
1870 l2 = l2 + isiz
1871 END DO
1872 ishift = ishift + 1
1873 ENDIF
1874
1875C -- IDTMINS==2
1876 IF(idtmins==2)THEN
1877 l = 0
1878 l2 = 0
1879 DO j = 1, nb
1880 i = index(j)
1881 nod = nsv(i)
1882 IF(nod<=numnod)THEN
1883 rbuf(p)%p(l+rshift) = t2fac_sms(nod)
1884 ibuf(p)%p(l2+ishift) = nodnx_sms(nod)
1885 ibuf(p)%p(l2+ishift+1)= nod
1886 ibuf(p)%p(l2+ishift+2)= t2main_sms(1,nod)
1887 ibuf(p)%p(l2+ishift+3)= t2main_sms(2,nod)
1888 ibuf(p)%p(l2+ishift+4)= t2main_sms(3,nod)
1889 ibuf(p)%p(l2+ishift+5)= t2main_sms(4,nod)
1890 ibuf(p)%p(l2+ishift+6)= t2main_sms(5,nod)
1891 ibuf(p)%p(l2+ishift+7)= t2main_sms(6,nod)
1892 ELSE
1893C E2E nodes (> NUMNOD) should not be need
1894C IRTSE Nodes are used.
1895 rbuf(p)%p(l+rshift) = one
1896 ibuf(p)%p(l2+ishift) = 0
1897 ibuf(p)%p(l2+ishift+1)= 0
1898 ibuf(p)%p(l2+ishift+2)= 0
1899 ibuf(p)%p(l2+ishift+3)= 0
1900 ibuf(p)%p(l2+ishift+4)= 0
1901 ibuf(p)%p(l2+ishift+5)= 0
1902 ibuf(p)%p(l2+ishift+6)= 0
1903 ibuf(p)%p(l2+ishift+7)= 0
1904 ENDIF
1905 l = l + rsiz
1906 l2 = l2 + isiz
1907 END DO
1908 rshift = rshift + 1
1909 ishift = ishift + 8
1910
1911C -- IDTMINS_INT /= 0
1912 ELSEIF(idtmins_int/=0)THEN
1913 l = 0
1914 l2 = 0
1915 DO j = 1, nb
1916 i = index(j)
1917 nod = nsv(i)
1918 rbuf(p)%p(l+rshift) = t2fac_sms(nod)
1919 ibuf(p)%p(l2+ishift)= nod
1920 ibuf(p)%p(l2+ishift+1)= t2main_sms(1,nod)
1921 ibuf(p)%p(l2+ishift+2)= t2main_sms(2,nod)
1922 ibuf(p)%p(l2+ishift+3)= t2main_sms(3,nod)
1923 ibuf(p)%p(l2+ishift+4)= t2main_sms(4,nod)
1924 ibuf(p)%p(l2+ishift+5)= t2main_sms(5,nod)
1925 ibuf(p)%p(l2+ishift+6)= t2main_sms(6,nod)
1926 l = l + rsiz
1927 l2 = l2 + isiz
1928 END DO
1929 rshift = rshift + 1
1930 ishift = ishift + 7
1931 ENDIF
1932
1933c INT24
1934 IF(ityp==24)THEN
1935 l = 0
1936 i24xremp = rshift
1937 DO j = 1, nb
1938 i = index(j)
1939 rbuf(p)%p(l+rshift) =i24_time_s(i)
1940 rbuf(p)%p(l+rshift+1) =i24_frfi(1,i)
1941 rbuf(p)%p(l+rshift+2) =i24_frfi(2,i)
1942 rbuf(p)%p(l+rshift+3) =i24_frfi(3,i)
1943 rbuf(p)%p(l+rshift+4) =i24_pene_old(1,i)
1944 rbuf(p)%p(l+rshift+5) =i24_stif_old(1,i)
1945 rbuf(p)%p(l+rshift+6) =i24_pene_old(3,i)
1946 rbuf(p)%p(l+rshift+7) =i24_pene_old(5,i)
1947 l = l + rsiz
1948 END DO
1949 rshift = rshift + 8
1950
1951 IF(istif_msdt > 0) THEN
1952 l = 0
1953 DO j = 1, nb
1954 i = index(j)
1955 rbuf(p)%p(l+rshift) =stifmsdt_s(i)
1956 l = l + rsiz
1957 END DO
1958 rshift = rshift + 1
1959 ENDIF
1960
1961 IF(ifsub_carea > 0) THEN
1962 l = 0
1963 DO j = 1, nb
1964 i = index(j)
1965 nod = nsv(i)
1966 rbuf(p)%p(l+rshift) =intarean(nod)
1967 l = l + rsiz
1968 END DO
1969 rshift = rshift + 1
1970 ENDIF
1971
1972 l2 = 0
1973 i24iremp = ishift
1974 DO j = 1, nb
1975 i = index(j)
1976
1977 ibuf(p)%p(l2+ishift) =i24_irtlm(1,i)
1978 ibuf(p)%p(l2+ishift+1)=i24_irtlm(2,i)
1979 ibuf(p)%p(l2+ishift+2)=i24_icont_i(i)
1980 l2 = l2 + isiz
1981
1982 END DO
1983 ishift = ishift + 3
1984C---pay attention in i24sto.F IREM(I24IREMP+3,N-NSN) is used,
1985C----change the shift value when new table was added like I24_ICONT_I
1986 IF (ilev==2) THEN
1987 l2 = 0
1988 DO j = 1, nb
1989 i = index(j)
1990 ibuf(p)%p(l2+ishift)=nbinflg(i)
1991 l2 = l2 + isiz
1992 END DO
1993 ishift = ishift + 1
1994 END IF
1995
1996C E2E IRTS
1997 i24irempnsne=ishift
1998 IF(iedge4>0)THEN
1999 l2 = 0
2000 DO j = 1, nb
2001 i = index(j)
2002 nod = nsv(i)
2003 IF(nod > numnod)THEN
2004
2005 nd = nod-numnod
2006C IRTS
2007 se=is2se(1,nd)
2008 n = irtse(1,se)
2009 ibuf(p)%p(l2+ishift) = abs(tag_sn(n))
2010 n = irtse(2,se)
2011 ibuf(p)%p(l2+ishift+1) = abs(tag_sn(n))
2012 n = irtse(3,se)
2013 ibuf(p)%p(l2+ishift+2) = abs(tag_sn(n))
2014 n = irtse(4,se)
2015 ibuf(p)%p(l2+ishift+3) = abs(tag_sn(n))
2016 ibuf(p)%p(l2+ishift+4) = irtse(5,se)
2017 ibuf(p)%p(l2+ishift+5) = is2pt(nd)
2018 ibuf(p)%p(l2+ishift+7) = ispt2(i)
2019 ibuf(p)%p(l2+ishift+6) = isegpt(i)
2020 ELSE
2021C Is not an Edge
2022 ibuf(p)%p(l2+ishift) = 0
2023 ibuf(p)%p(l2+ishift+1) = 0
2024 ibuf(p)%p(l2+ishift+2) = 0
2025 ibuf(p)%p(l2+ishift+3) = 0
2026 ibuf(p)%p(l2+ishift+4) = 0
2027 ibuf(p)%p(l2+ishift+5) = 0
2028 ibuf(p)%p(l2+ishift+7) = ispt2(i)
2029 ibuf(p)%p(l2+ishift+6) = tag_2ry(i)
2030 ENDIF
2031
2032c IF( ISEGPT(ND) < 0)THEN
2033c IBUF(P)%p(L2+ISHIFT+6) = ISEGPT(ND)
2034c ELSE
2035c IBUF(P)%p(L2+ISHIFT+6) = TAG_2RY(I)
2036c ENDIF
2037
2038
2039 l2 = l2 + isiz
2040 END DO
2041
2042 ishift = ishift + 8
2043 ENDIF
2044
2045 END IF !(ITYP==24)
2046C
2047 !save specifics IREM and XREM indexes for INT24 sorting
2048 l2 = 0
2049 DO j = 1, nb
2050 i = index(j)
2051 nod = nsv(i)
2052 !save specifics IREM and XREM indexes for INT24 sorting
2053 ibuf(p)%p(l2+4) = igapxremp
2054 ibuf(p)%p(l2+5) = i24xremp
2055 ibuf(p)%p(l2+6) = i24iremp
2056 ibuf(p)%p(l2+7) = i24irempnsne
2057 l2 = l2 + isiz
2058 END DO
2059
2060C NITSCHE
2061 IF(intnitsche > 0 ) THEN
2062 l = 0
2063 DO j = 1, nb
2064 i = index(j)
2065 nod = nsv(i)
2066 rbuf(p)%p(l+rshift) =forneqs(1,nod)
2067 rbuf(p)%p(l+rshift+1) =forneqs(2,nod)
2068 rbuf(p)%p(l+rshift+2) =forneqs(3,nod)
2069 l = l + rsiz
2070 END DO
2071 rshift = rshift + 3
2072 ENDIF
2073
2074 msgtyp = msgoff4
2075 CALL spmd_isend(
2076 1 rbuf(p)%P(1),nb*rsiz,it_spmd(p),msgtyp,
2077 2 req_sd2(p))
2078
2079 msgtyp = msgoff5
2080 CALL spmd_isend(
2081 1 ibuf(p)%P(1),nb*isiz,it_spmd(p),msgtyp,
2082 2 req_sd3(p))
2083
2084 ENDIF
2085 ENDDO
2086 ENDIF
2087C
2088C reception of XREM data
2089C
2090 IF(ircvfrom(nin,loc_proc)/=0) THEN
2091 nsnr = 0
2092 l=0
2093 DO p = 1, nspmd
2094 nsnfi(nin)%P(p) = 0
2095 IF(isendto(nin,p)/=0) THEN
2096 IF(loc_proc/=p) THEN
2097 msgtyp = msgoff3
2098 CALL spmd_recv(nsnfi(nin)%P(p),1,it_spmd(p),
2099 . msgtyp)
2100
2101 IF(nsnfi(nin)%P(p)>0) THEN
2102 l=l+1
2103 isindexi(l)=p
2104 nsnr = nsnr + nsnfi(nin)%P(p)
2105 ENDIF
2106 ENDIF
2107 ENDIF
2108 ENDDO
2109 nbirecv=l
2110C
2111C Allocate total size
2112C
2113
2114 IF(nsnr>0) THEN
2115
2116 ALLOCATE(xrem(rsiz,nsnr),stat=ierror)
2117 ALLOCATE(irem(isiz,nsnr),stat=ierror)
2118
2119 IF(ierror/=0) THEN
2120 CALL ancmsg(msgid=20,anmode=aninfo)
2121 CALL arret(2)
2122 ENDIF
2123 ideb = 1
2124 DO l = 1, nbirecv
2125 p = isindexi(l)
2126 len = nsnfi(nin)%P(p)*rsiz
2127 msgtyp = msgoff4
2128
2129 CALL spmd_irecv(
2130 1 xrem(1,ideb),len,it_spmd(p),
2131 2 msgtyp,req_rd(l))
2132
2133 len2 = nsnfi(nin)%P(p)*isiz
2134 msgtyp = msgoff5
2135 CALL spmd_irecv(
2136 1 irem(1,ideb),len2,it_spmd(p),
2137 2 msgtyp,req_rd2(l))
2138
2139 ideb = ideb + nsnfi(nin)%P(p)
2140 ENDDO
2141 DO l = 1, nbirecv
2142 CALL spmd_waitany(nbirecv,req_rd,indexi)
2143 CALL spmd_waitany(nbirecv,req_rd2,indexi)
2144 ENDDO
2145
2146 !set specifics IREM and XREM indexes for INT24 sorting
2147 igapxremp = irem(4,1)
2148 i24xremp = irem(5,1)
2149 i24iremp = irem(6,1)
2150 i24irempnsne = irem(7,1)
2151C with E2E fictive nodes
2152C One needs to shift the IRTSE in order to be found (SHIFT to IDEB)
2153 IF(iedge4 >0)THEN
2154 ideb=0
2155
2156 DO l = 1, nbirecv
2157 p = isindexi(l)
2158 len = nsnfi(nin)%P(p)
2159 DO i=1,len
2160 IF(irem(8,i+ideb)==1)THEN
2161 irem(i24irempnsne ,i+ideb)=irem(i24irempnsne ,i+ideb) + ideb
2162 irem(i24irempnsne+1,i+ideb)=irem(i24irempnsne+1,i+ideb) + ideb
2163 irem(i24irempnsne+2,i+ideb)=irem(i24irempnsne+2,i+ideb) + ideb
2164 irem(i24irempnsne+3,i+ideb)=irem(i24irempnsne+3,i+ideb) + ideb
2165 ENDIF
2166 ENDDO
2167 ideb = ideb + len
2168 ENDDO
2169 ENDIF
2170 ENDIF
2171 ENDIF
2172C
2173 IF(ircvfrom(nin,loc_proc)/=0) THEN
2174 DO p = 1, nspmd
2175 IF(isendto(nin,p)/=0) THEN
2176 IF(p/=loc_proc) THEN
2177 CALL spmd_wait(req_sb(p))
2178 CALL spmd_wait(req_sc(p))
2179 ENDIF
2180 ENDIF
2181 ENDDO
2182 ENDIF
2183C
2184 IF(isendto(nin,loc_proc)/=0) THEN
2185 DO p = 1, nspmd
2186 IF(ircvfrom(nin,p)/=0) THEN
2187 IF(p/=loc_proc) THEN
2188 CALL spmd_wait(req_sd(p))
2189 IF(nbox(p)/=0) THEN
2190 CALL spmd_wait(req_sd2(p))
2191 DEALLOCATE(rbuf(p)%p)
2192 CALL spmd_wait(req_sd3(p))
2193 DEALLOCATE(ibuf(p)%p)
2194 END IF
2195 ENDIF
2196 ENDIF
2197 ENDDO
2198 ENDIF
2199C
2200 IF(ALLOCATED(tag_sn)) DEALLOCATE(tag_sn)
2201 IF(ALLOCATED(tag_sn)) DEALLOCATE(indexe)
2202
2203#endif
2204C
2205 RETURN

◆ spmd_tri24vox0()

subroutine spmd_tri24vox0 ( x,
bminmal,
integer nrtm,
stf,
marge,
curv_max,
gap_m,
integer, dimension(4,*) irect,
gap,
bgapsmx,
pmax_gap,
vmaxdt,
intent(in) dgapload )

Definition at line 5528 of file spmd_int.F.

5532C-----------------------------------------------
5533C M o d u l e s
5534C-----------------------------------------------
5535 USE tri7box
5536 USE spmd_mod
5537C-----------------------------------------------
5538C I m p l i c i t T y p e s
5539C-----------------------------------------------
5540#include "implicit_f.inc"
5541#include "comlock.inc"
5542C-----------------------------------------------
5543C C o m m o n B l o c k s
5544C-----------------------------------------------
5545#include "task_c.inc"
5546C-----------------------------------------------
5547C D u m m y A r g u m e n t s
5548C-----------------------------------------------
5549 INTEGER NRTM, IRECT(4,*)
5550 my_real
5551 . x(3,*), bminmal(*),
5552 . stf(*), gap_m(*), bgapsmx,pmax_gap,vmaxdt,
5553 . marge,gap,curv_max(nrtm)
5554 my_real , INTENT(IN) :: dgapload
5555C-----------------------------------------------
5556C L o c a l V a r i a b l e s
5557C-----------------------------------------------
5558 INTEGER LOC_PROC,
5559 . NBX,NBY,NBZ,NE,M1,M2,M3,M4,
5560 . IX1,IY1,IZ1,IX2,IY2,IZ2,IX,IY,IZ
5561 my_real
5562 . ratio, aaa,
5563 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
5564 . xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,
5565 . xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4
5566c DATA IPWR2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,
5567c . 16384,32768,65536,131072,262144,524288,1048576,
5568c . 2097152,4194304,8388608,16777216,33554432,67108864,
5569c . 134217728,268435456,536870912,1073741824,2147483648/
5570C-----------------------------------------------
5571C S o u r c e L i n e s
5572C-----------------------------------------------
5573C
5574C=======================================================================
5575C tag of boxes containing facets
5576C and creation of candidates
5577C=======================================================================
5578
5579 loc_proc = ispmd + 1
5580
5581 nbx = lrvoxel
5582 nby = lrvoxel
5583 nbz = lrvoxel
5584
5585 xmaxb = bminmal(1)
5586 ymaxb = bminmal(2)
5587 zmaxb = bminmal(3)
5588 xminb = bminmal(4)
5589 yminb = bminmal(5)
5590 zminb = bminmal(6)
5591
5592 DO ne=1,nrtm
5593C We do not retain the Destruit facets
5594 IF(stf(ne) == zero)cycle
5595 aaa = marge+curv_max(ne)+vmaxdt
5596 + + max(pmax_gap,bgapsmx+gap_m(ne))+dgapload
5597
5598c It is possible to improve the algo by cutting the facet
5599c in 2 (4,3,6,9 ...) if the facet is large in front of AAA and inclinee
5600
5601 m1 = irect(1,ne)
5602 m2 = irect(2,ne)
5603 m3 = irect(3,ne)
5604 m4 = irect(4,ne)
5605
5606 xx1=x(1,m1)
5607 xx2=x(1,m2)
5608 xx3=x(1,m3)
5609 xx4=x(1,m4)
5610 xmaxe=max(xx1,xx2,xx3,xx4)
5611 xmine=min(xx1,xx2,xx3,xx4)
5612
5613 yy1=x(2,m1)
5614 yy2=x(2,m2)
5615 yy3=x(2,m3)
5616 yy4=x(2,m4)
5617 ymaxe=max(yy1,yy2,yy3,yy4)
5618 ymine=min(yy1,yy2,yy3,yy4)
5619
5620 zz1=x(3,m1)
5621 zz2=x(3,m2)
5622 zz3=x(3,m3)
5623 zz4=x(3,m4)
5624 zmaxe=max(zz1,zz2,zz3,zz4)
5625 zmine=min(zz1,zz2,zz3,zz4)
5626
5627c index of voxels occupied by the facet
5628
5629 ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
5630 iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
5631 iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
5632
5633 ix1=max(0,min(nbx,ix1))
5634 iy1=max(0,min(nby,iy1))
5635 iz1=max(0,min(nbz,iz1))
5636
5637 ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
5638 iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
5639 iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
5640
5641 ix2=max(0,min(nbx,ix2))
5642 iy2=max(0,min(nby,iy2))
5643 iz2=max(0,min(nbz,iz2))
5644
5645#include "lockon.inc"
5646 DO iz = iz1, iz2
5647 DO iy = iy1, iy2
5648 DO ix = ix1, ix2
5649 crvoxel(iy,iz,loc_proc)=ibset(crvoxel(iy,iz,loc_proc),ix)
5650 END DO
5651 END DO
5652 END DO
5653#include "lockoff.inc"
5654
5655 ENDDO
5656
5657C
5658 RETURN

◆ spmd_tri7gat()

subroutine spmd_tri7gat ( integer result,
integer nsn,
integer, dimension(*) cand_n,
integer i_stok,
integer nin,
integer igap,
integer nsnr,
integer multimp,
integer ity,
integer intth,
integer ilev,
integer, dimension(*) nsnfiold,
integer, dimension(npari,ninter) ipari,
type(h3d_database) h3d_data,
integer intfric,
type(multi_fvm_struct) multi_fvm,
integer, intent(in) nodadt_therm )

Definition at line 3000 of file spmd_int.F.

3004C-----------------------------------------------
3005C M o d u l e s
3006C-----------------------------------------------
3007 USE tri7box
3008 USE message_mod
3009 USE h3d_mod
3010 USE multi_fvm_mod
3011 USE spmd_mod
3012C-----------------------------------------------
3013C I m p l i c i t T y p e s
3014C-----------------------------------------------
3015#include "implicit_f.inc"
3016C-----------------------------------------------
3017C C o m m o n B l o c k s
3018C-----------------------------------------------
3019#include "com01_c.inc"
3020#include "com04_c.inc"
3021#include "task_c.inc"
3022#include "scr14_c.inc"
3023#include "scr16_c.inc"
3024#include "scr18_c.inc"
3025#include "param_c.inc"
3026#include "parit_c.inc"
3027#include "spmd_c.inc"
3028#include "sms_c.inc"
3029C-----------------------------------------------
3030C D u m m y A r g u m e n t s
3031C-----------------------------------------------
3032 INTEGER RESULT, NIN, NSN, I_STOK, IGAP, NSNR, MULTIMP, ITY,
3033 . CAND_N(*),INTTH,ILEV, INTFRIC,
3034 . NSNFIOLD(*), IPARI(NPARI,NINTER)
3035 INTEGER , INTENT(IN) :: NODADT_THERM
3036 TYPE(H3D_DATABASE) :: H3D_DATA
3037 TYPE(MULTI_FVM_STRUCT) :: MULTI_FVM
3038C-----------------------------------------------
3039C L o c a l V a r i a b l e s
3040C-----------------------------------------------
3041#ifdef MPI
3042 INTEGER OLDNSNR,NODFI,NNP,LSKYFI,
3043 . NOD, LOC_PROC, I, N, NN, P, IDEB, J, K,
3044 . IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,IERROR6,IERROR7,
3045 . IERROR8,IERROR9,IERROR0,IERROR11,IERROR12,
3046 . IERROR13,IERROR14,IERROR15,IERROR16,IERROR17,INDEX(NSNR),
3047 . NN2,RSHIFT,ISHIFT, IOLDNSNFI, ND, JDEB, NSNR_OLD, Q
3048
3049 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX
3050C-----------------------------------------------
3051C S o u r c e L i n e s
3052C-----------------------------------------------
3053 loc_proc = ispmd + 1
3054C
3055C
3056 nodfi = 0
3057 lskyfi= 0
3058
3059 IF(result==0) THEN
3060C
3061C identification of candidates
3062C
3063 DO i = 1, i_stok
3064 n = cand_n(i)
3065 nn = n-nsn
3066 IF(nn>0)THEN
3067 IF(irem(1,nn)>0)THEN
3068 nodfi = nodfi + 1
3069 irem(1,nn) = -irem(1,nn)
3070 ENDIF
3071 ENDIF
3072 ENDDO
3073C
3074C allocation of interface boundary arrays
3075C
3076 ierror1 = 0
3077 ierror2 = 0
3078 ierror3 = 0
3079 ierror4 = 0
3080 ierror5 = 0
3081 ierror6 = 0
3082 ierror7 = 0
3083 ierror8 = 0
3084 ierror9 = 0
3085 ierror0 = 0
3086 ierror11 = 0
3087 ierror12 = 0
3088 ierror13 = 0
3089 ierror14 = 0
3090 ierror15 = 0
3091 ierror16 = 0
3092 ierror17 = 0
3093
3094 IF(ASSOCIATED(nsvfi(nin)%P)) DEALLOCATE(nsvfi(nin)%P)
3095 ALLOCATE(nsvfi(nin)%P(nodfi),stat=ierror1)
3096 IF(ASSOCIATED(pmainfi(nin)%P)) DEALLOCATE(pmainfi(nin)%P)
3097 ALLOCATE(pmainfi(nin)%P(nodfi),stat=ierror2)
3098 ierror1 = ierror2 + ierror1
3099 IF(ASSOCIATED(xfi(nin)%P)) DEALLOCATE(xfi(nin)%P)
3100 ALLOCATE(xfi(nin)%P(3,nodfi),stat=ierror2)
3101 IF(ASSOCIATED(vfi(nin)%P)) DEALLOCATE(vfi(nin)%P)
3102 ALLOCATE(vfi(nin)%P(3,nodfi),stat=ierror3)
3103 IF(ASSOCIATED(msfi(nin)%P)) DEALLOCATE(msfi(nin)%P)
3104 ALLOCATE(msfi(nin)%P(nodfi),stat=ierror4)
3105 IF(ASSOCIATED(stifi(nin)%P)) DEALLOCATE(stifi(nin)%P)
3106 ALLOCATE(stifi(nin)%P(nodfi),stat=ierror5)
3107 IF(ASSOCIATED(itafi(nin)%P)) DEALLOCATE(itafi(nin)%P)
3108 ALLOCATE(itafi(nin)%P(nodfi),stat=ierror6)
3109 IF(ity==7.OR.ity==22.OR.ity==23.OR.ity==24) THEN
3110 IF(ASSOCIATED(kinfi(nin)%P)) DEALLOCATE(kinfi(nin)%P)
3111 ALLOCATE(kinfi(nin)%P(nodfi),stat=ierror8)
3112 IF(intth > 0 ) THEN
3113 IF(ASSOCIATED(tempfi(nin)%P)) DEALLOCATE(tempfi(nin)%P)
3114 ALLOCATE(tempfi(nin)%P(nodfi),stat=ierror9)
3115 IF(ASSOCIATED(matsfi(nin)%P)) DEALLOCATE(matsfi(nin)%P)
3116 ALLOCATE(matsfi(nin)%P(nodfi),stat=ierror0)
3117 IF(ASSOCIATED(areasfi(nin)%P)) DEALLOCATE(areasfi(nin)%P)
3118 ALLOCATE(areasfi(nin)%P(nodfi),stat=ierror11)
3119 ENDIF
3120 ENDIF
3121 IF(idtmins == 2) THEN
3122 IF(ASSOCIATED(nodnxfi(nin)%P)) DEALLOCATE(nodnxfi(nin)%P)
3123 ALLOCATE(nodnxfi(nin)%P(nodfi),stat=ierror12)
3124 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
3125 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
3126 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
3127 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
3128 ELSEIF(idtmins_int /= 0) THEN
3129 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
3130 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
3131 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
3132 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
3133 ENDIF
3134 IF(igap/=0) THEN
3135 IF(ASSOCIATED(gapfi(nin)%P)) DEALLOCATE(gapfi(nin)%P)
3136 ALLOCATE(gapfi(nin)%P(nodfi),stat=ierror7)
3137 IF(igap==3) THEN
3138 IF(ASSOCIATED(gap_lfi(nin)%P)) DEALLOCATE(gap_lfi(nin)%P)
3139 ALLOCATE(gap_lfi(nin)%P(nodfi),stat=ierror7)
3140 ENDIF
3141 ENDIF
3142 IF(ity==24)THEN
3143 IF(ASSOCIATED(irtlm_fi(nin)%P)) DEALLOCATE(irtlm_fi(nin)%P)
3144 ALLOCATE(irtlm_fi(nin)%P(2,nodfi),stat=ierror15)
3145
3146 IF(ASSOCIATED(time_sfi(nin)%P)) DEALLOCATE(time_sfi(nin)%P)
3147 ALLOCATE(time_sfi(nin)%P(nodfi),stat=ierror16)
3148
3149 IF(ASSOCIATED(secnd_frfi(nin)%P)) DEALLOCATE(secnd_frfi(nin)%P)
3150 ALLOCATE(secnd_frfi(nin)%P(6,nodfi),stat=ierror16)
3151
3152 IF(ASSOCIATED(pene_oldfi(nin)%P))DEALLOCATE(pene_oldfi(nin)%P)
3153 ALLOCATE(pene_oldfi(nin)%P(5,nodfi),stat=ierror16)
3154
3155 IF(ASSOCIATED(stif_oldfi(nin)%P))DEALLOCATE(stif_oldfi(nin)%P)
3156 ALLOCATE(stif_oldfi(nin)%P(2,nodfi),stat=ierror16)
3157
3158 IF(ASSOCIATED(icont_i_fi(nin)%P))DEALLOCATE(icont_i_fi(nin)%P)
3159 ALLOCATE(icont_i_fi(nin)%P(nodfi),stat=ierror16)
3160 ENDIF
3161c
3162 IF(ity==7) THEN
3163 IF(intfric > 0 ) THEN
3164 IF(ASSOCIATED(ipartfricsfi(nin)%P)) DEALLOCATE(ipartfricsfi(nin)%P)
3165 ALLOCATE(ipartfricsfi(nin)%P(nodfi),stat=ierror0)
3166 ENDIF
3167 ENDIF
3168C
3169 ! ----------------------
3170 ! /TYPE18 + /LAW 151
3171 IF( multi_fvm%IS_INT18_LAW151.AND.iparit/=0 ) THEN
3172 ! -----------
3173 ! check if the present interface is a TYPE18+LAW151
3174 IF( multi_fvm%INT18_GLOBAL_LIST(nin) ) THEN
3175 IF( ALLOCATED( multi_fvm%R_AFI(nin)%R_FORCE_INT ) ) DEALLOCATE( multi_fvm%R_AFI(nin)%R_FORCE_INT )
3176 multi_fvm%R_AFI(nin)%NODFI = nodfi
3177 ALLOCATE( multi_fvm%R_AFI(nin)%R_FORCE_INT(3,6,nodfi*nthread) )
3178 multi_fvm%R_AFI(nin)%R_FORCE_INT(1:3,1:6,1:nodfi*nthread) = 0d+00
3179 ENDIF
3180 ENDIF
3181 ! ----------------------
3182
3183C
3184 IF(ierror1+ierror2+ierror3+ierror4+ierror5+
3185 + ierror6+ierror7+ierror8 + ierror9 + ierror0 +
3186 + ierror11+ierror12+ierror13+ierror14+ierror15+
3187 + ierror16+ierror17/= 0) THEN
3188 CALL ancmsg(msgid=20,anmode=aninfo)
3189 CALL arret(2)
3190 ENDIF
3191C
3192C compaction of candidates
3193C
3194 ideb = 0
3195 nn2 = 0
3196
3197 jdeb = 0
3198
3199 DO p = 1, nspmd
3200 nn = 0
3201 oldnsnr = nsnfi(nin)%P(p)
3202
3203 IF(oldnsnr/=0) THEN
3204
3205 ALLOCATE(iaux(oldnsnr),stat=ierror17)
3206 IF(ierror17/=0) THEN
3207 CALL ancmsg(msgid=20,anmode=aninfo)
3208 CALL arret(2)
3209 ENDIF
3210
3211 nnp = nn2
3212
3213 DO i = 1, oldnsnr
3214 IF(irem(1,i+ideb)<0) THEN
3215 nn = nn + 1
3216 iaux(nn) = i
3217 ENDIF
3218 ENDDO
3219
3220c general case
3221#include "vectorize.inc"
3222 DO j = 1, nn
3223 i = iaux(j)
3224 index(i+ideb) = nn2+j
3225 xfi(nin)%P(1,nn2+j) = xrem(1,i+ideb)
3226 xfi(nin)%P(2,nn2+j) = xrem(2,i+ideb)
3227 xfi(nin)%P(3,nn2+j) = xrem(3,i+ideb)
3228 vfi(nin)%P(1,nn2+j) = xrem(4,i+ideb)
3229 vfi(nin)%P(2,nn2+j) = xrem(5,i+ideb)
3230 vfi(nin)%P(3,nn2+j) = xrem(6,i+ideb)
3231 msfi(nin)%P(nn2+j) = xrem(7,i+ideb)
3232 stifi(nin)%P(nn2+j) = xrem(8,i+ideb)
3233 nsvfi(nin)%P(nn2+j) = -irem(1,i+ideb)
3234 itafi(nin)%P(nn2+j) = irem(2,i+ideb)
3235 kinfi(nin)%P(nn2+j) = irem(3,i+ideb)
3236 pmainfi(nin)%P(nn2+j) = p
3237
3238
3239 !ignore specifics IREM and XREM indexes for INT24 sorting
3240 !IGAPXREMP = IREM(4,I+IDEB)
3241 !I24XREMP = IREM(5,I+IDEB)
3242 !I24IREMP = IREM(6,I+IDEB)
3243 ENDDO
3244
3245c shift for real variables (prepare for next setting)
3246 rshift = 9
3247c shift for integer variables (prepare for next setting)
3248 ishift = 7
3249
3250c IGAP=1 or IGAP=2
3251 IF(igap==1 .OR. igap==2)THEN
3252#include "vectorize.inc"
3253 DO j = 1, nn
3254 i = iaux(j)
3255 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
3256 ENDDO
3257 rshift = rshift + 1
3258c IGAP=3
3259 ELSEIF(igap==3)THEN
3260#include "vectorize.inc"
3261 DO j = 1, nn
3262 i = iaux(j)
3263 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
3264 gap_lfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
3265 ENDDO
3266 rshift = rshift + 2
3267 ENDIF
3268
3269C thermic
3270 IF(intth>0)THEN
3271#include "vectorize.inc"
3272 DO j = 1, nn
3273 i = iaux(j)
3274 tempfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
3275 areasfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
3276 matsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
3277 ENDDO
3278 rshift = rshift + 2
3279 ishift = ishift + 1
3280 ENDIF
3281
3282C Friction model
3283 IF(intfric>0)THEN
3284#include "vectorize.inc"
3285 DO j = 1, nn
3286 i = iaux(j)
3287 ipartfricsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
3288 ENDDO
3289 ishift = ishift + 1
3290 ENDIF
3291
3292C -- IDTMINS==2
3293 IF(idtmins==2)THEN
3294#include "vectorize.inc"
3295 DO j = 1, nn
3296 i = iaux(j)
3297 nodnxfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
3298 nodamsfi(nin)%P(nn2+j) = irem(ishift+1,i+ideb)
3299 procamsfi(nin)%P(nn2+j) = p
3300 ENDDO
3301 ishift = ishift + 2
3302
3303C -- IDTMINS_INT /= 0
3304 ELSEIF(idtmins_int/=0)THEN
3305#include "vectorize.inc"
3306 DO j = 1, nn
3307 i = iaux(j)
3308 nodamsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
3309 procamsfi(nin)%P(nn2+j) = p
3310 ENDDO
3311 ishift = ishift + 1
3312 ENDIF
3313
3314c INT24
3315 IF(ity==24)THEN
3316#include "vectorize.inc"
3317 DO j = 1, nn
3318 i = iaux(j)
3319 irtlm_fi(nin)%P(1,nn2+j) =irem(ishift,i+ideb)
3320 irtlm_fi(nin)%P(2,nn2+j) =irem(ishift+1,i+ideb)
3321 icont_i_fi(nin)%P(nn2+j) = irem(ishift+2,i+ideb)
3322 time_sfi(nin)%P(nn2+j ) =xrem(rshift,i+ideb)
3323 secnd_frfi(nin)%P(1,nn2+j) =zero
3324 secnd_frfi(nin)%P(2,nn2+j) =zero
3325 secnd_frfi(nin)%P(3,nn2+j) =zero
3326 secnd_frfi(nin)%P(4,nn2+j) =xrem(rshift+1,i+ideb)
3327 secnd_frfi(nin)%P(5,nn2+j) =xrem(rshift+2,i+ideb)
3328 secnd_frfi(nin)%P(6,nn2+j) =xrem(rshift+3,i+ideb)
3329 pene_oldfi(nin)%P(1,nn2+j)=zero
3330 stif_oldfi(nin)%P(1,nn2+j)=zero
3331 pene_oldfi(nin)%P(2,nn2+j)=xrem(rshift+4,i+ideb)
3332 stif_oldfi(nin)%P(2,nn2+j)=xrem(rshift+5,i+ideb)
3333C
3334C We Store PENE_OLD(3 in PENE_OLD(4 during sorting
3335 pene_oldfi(nin)%P(4,nn2+j)=xrem(rshift+6,i+ideb)
3336 pene_oldfi(nin)%P(5,nn2+j)=xrem(rshift+7,i+ideb)
3337 ENDDO
3338 rshift = rshift + 8
3339 ishift = ishift + 3
3340 IF (ilev==2) ishift = ishift + 1
3341 ENDIF
3342
3343
3344 nn2 = nn2 + nn
3345 ideb = ideb + oldnsnr
3346 nsnfi(nin)%P(p) = nn2-nnp
3347
3348 DEALLOCATE(iaux)
3349
3350 ENDIF !IF(OLDNSNR/=0)
3351
3352 ENDDO ! end do NSPMD
3353
3354 lskyfi = nn2*multimax
3355C NSNR New useful for inactive
3356 nsnr = nn2
3357 ENDIF
3358C
3359C deallocation of XREM IREM
3360C
3361 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
3362 IF(ALLOCATED(irem)) DEALLOCATE(irem)
3363
3364C
3365 ierror1=0
3366 ierror2=0
3367 ierror3=0
3368 ierror4=0
3369 IF(intth == 0 ) THEN
3370C
3371C Allocation Parith/OFF
3372C
3373 IF(iparit==0) THEN
3374
3375 IF(ASSOCIATED(afi(nin)%P)) THEN
3376 DEALLOCATE(afi(nin)%P)
3377 NULLIFY(afi(nin)%P)
3378 ENDIF
3379 IF(ASSOCIATED(stnfi(nin)%P)) THEN
3380 DEALLOCATE(stnfi(nin)%P)
3381 NULLIFY(afi(nin)%P)
3382 ENDIF
3383
3384 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
3385 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
3386C Init a 0
3387 DO i = 1, nodfi*nthread
3388 afi(nin)%P(1,i) = zero
3389 afi(nin)%P(2,i) = zero
3390 afi(nin)%P(3,i) = zero
3391 stnfi(nin)%P(i) = zero
3392 ENDDO
3393C
3394 IF(kdtint/=0)THEN
3395 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
3396 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
3397C Init a 0
3398 DO i = 1, nodfi*nthread
3399 vscfi(nin)%P(i) = zero
3400 ENDDO
3401 ENDIF
3402 nlskyfi(nin) = nodfi
3403C
3404 ELSE
3405C
3406C Allocation Parith/ON Done in upgrade_rem_slv
3407C
3408 ENDIF
3409 ELSE
3410C
3411C Allocation Parith/OFF
3412C
3413 IF(iparit==0) THEN
3414 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
3415 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
3416 IF(ASSOCIATED(fthefi(nin)%P)) DEALLOCATE(fthefi(nin)%P)
3417 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
3418 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
3419 IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror3)
3420C
3421 IF(nodadt_therm ==1) THEN
3422 IF(ASSOCIATED(condnfi(nin)%P)) DEALLOCATE(condnfi(nin)%P)
3423 IF(nodfi>0.AND.nodadt_therm ==1)ALLOCATE(condnfi(nin)%P(nodfi*nthread),stat=ierror4)
3424 ENDIF
3425C
3426
3427
3428C Init a 0
3429
3430 DO i = 1, nodfi*nthread
3431 afi(nin)%P(1,i) = zero
3432 afi(nin)%P(2,i) = zero
3433 afi(nin)%P(3,i) = zero
3434 stnfi(nin)%P(i) = zero
3435 fthefi(nin)%P(i) = zero
3436 ENDDO
3437 IF(nodadt_therm ==1) THEN
3438 DO i = 1, nodfi
3439 condnfi(nin)%P(i) = zero
3440 ENDDO
3441 ENDIF
3442C
3443 IF(kdtint/=0)THEN
3444 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
3445 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi),stat=ierror4)
3446C Init a 0
3447 DO i = 1, nodfi
3448 vscfi(nin)%P(i) = zero
3449 ENDDO
3450 ENDIF
3451C
3452 ELSE
3453C
3454C Allocation Parith/ON Upgrade_rem_slv
3455C
3456
3457
3458 ENDIF
3459 ENDIF
3460C
3461 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
3462 CALL ancmsg(msgid=20,anmode=aninfo)
3463 CALL arret(2)
3464 ENDIF
3465C
3466C Output Pressure conditional allowances
3467C
3468 IF(anim_v(12)+outp_v(12)+h3d_data%N_VECT_PCONT >0)THEN
3469 IF(ASSOCIATED(fnconti(nin)%P)) DEALLOCATE(fnconti(nin)%P)
3470 IF(ASSOCIATED(ftconti(nin)%P)) DEALLOCATE(ftconti(nin)%P)
3471 ALLOCATE(fnconti(nin)%P(3,nodfi),stat=ierror1)
3472 ALLOCATE(ftconti(nin)%P(3,nodfi),stat=ierror2)
3473 IF(ierror1+ierror2/=0) THEN
3474 CALL ancmsg(msgid=20,anmode=aninfo)
3475 CALL arret(2)
3476 ELSE
3477 DO j = 1, nodfi
3478 fnconti(nin)%P(1,j)=zero
3479 fnconti(nin)%P(2,j)=zero
3480 fnconti(nin)%P(3,j)=zero
3481 ftconti(nin)%P(1,j)=zero
3482 ftconti(nin)%P(2,j)=zero
3483 ftconti(nin)%P(3,j)=zero
3484 END DO
3485 END IF
3486 END IF
3487
3488 IF(h3d_data%N_SCAL_CSE_FRICINT >0)THEN
3489 IF(h3d_data%N_CSE_FRIC_INTER (nin) >0)THEN
3490 IF(ASSOCIATED(efricfi(nin)%P)) DEALLOCATE(efricfi(nin)%P)
3491 ALLOCATE(efricfi(nin)%P(nodfi),stat=ierror1)
3492 IF(ierror1/=0) THEN
3493 CALL ancmsg(msgid=20,anmode=aninfo)
3494 CALL arret(2)
3495 ELSE
3496 DO j = 1, nodfi
3497 efricfi(nin)%P(j)=zero
3498 END DO
3499 END IF
3500 END IF
3501 ENDIF
3502 IF(h3d_data%N_SCAL_CSE_FRIC >0)THEN
3503 IF(ASSOCIATED(efricgfi(nin)%P)) DEALLOCATE(efricgfi(nin)%P)
3504 ALLOCATE(efricgfi(nin)%P(nodfi),stat=ierror1)
3505 IF(ierror1/=0) THEN
3506 CALL ancmsg(msgid=20,anmode=aninfo)
3507 CALL arret(2)
3508 ELSE
3509 DO j = 1, nodfi
3510 efricgfi(nin)%P(j)=zero
3511 END DO
3512 END IF
3513 END IF
3514C
3515C
3516C renumbering of candidates
3517C
3518 DO i = 1, i_stok
3519 n = cand_n(i)
3520 nn = n-nsn
3521 IF(nn>0)THEN
3522 cand_n(i) = index(nn)+nsn
3523 ENDIF
3524 ENDDO
3525C
3526#endif
3527 RETURN
tri7box::pmainfi
type(int_pointer), dimension(:), allocatable pmainfi
Definition tri7box.F:435

◆ spmd_tri7vox()

subroutine spmd_tri7vox ( integer, dimension(*) nsv,
integer nsn,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifn,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nsnr,
integer igap,
gap_s,
integer, dimension(*) itab,
integer, dimension(*) kinet,
integer ifq,
integer inacti,
integer, dimension(*) nsnfiold,
integer intth,
integer, dimension(*) ielec,
areas,
temp,
integer num_imp,
integer, dimension(*) nodnx_sms,
gap_s_l,
integer ityp,
integer, dimension(*) irtlm,
i24_time_s,
i24_frfi,
i24_pene_old,
i24_stif_old,
integer, dimension(*) nbinflg,
integer ilev,
integer, dimension(*) i24_icont_i,
integer intfric,
integer, dimension(*) ipartfrics,
integer itied,
integer ivis2,
integer, dimension(*) if_adh )

Definition at line 210 of file spmd_int.F.

220C-----------------------------------------------
221C M o d u l e s
222C-----------------------------------------------
223 USE tri7box
224 USE message_mod
225 USE spmd_mod
226C-----------------------------------------------
227C I m p l i c i t T y p e s
228C-----------------------------------------------
229#include "implicit_f.inc"
230C-----------------------------------------------
231C M e s s a g e P a s s i n g
232C-----------------------------------------------
233C-----------------------------------------------
234C C o m m o n B l o c k s
235C-----------------------------------------------
236#include "com01_c.inc"
237#include "com04_c.inc"
238#include "task_c.inc"
239#include "timeri_c.inc"
240#include "sms_c.inc"
241C-----------------------------------------------
242C D u m m y A r g u m e n t s
243C-----------------------------------------------
244 INTEGER NIN, NSN, IFQ, INACTI, IGAP,INTTH,NSNR,INTFRIC,
245 . ITIED, IVIS2,
246 . NSNFIOLD(*), NSV(*), WEIGHT(*),
247 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
248 . IAD_ELEM(2,*), FR_ELEM(*), ITAB(*), KINET(*),
249 . IELEC(*),NUM_IMP, NODNX_SMS(*),IRTLM(*),ITYP,
250 . NBINFLG(*),ILEV,I24_ICONT_I(*),IPARTFRICS(*),IF_ADH(*)
251
252 my_real
253 . x(3,*), v(3,*), ms(*), bminmal(*), stifn(*), gap_s(*),
254 . areas(*),temp(*),gap_s_l(*),i24_time_s(*),i24_frfi(6,*),
255 . i24_pene_old(5,*),i24_stif_old(2,*)
256C-----------------------------------------------
257C L o c a l V a r i a b l e s
258C-----------------------------------------------
259#ifdef MPI
260 INTEGER MSGTYP, I, NOD, LOC_PROC, P, IDEB,
261 . SIZ,J, L, BUFSIZ, LEN, NB, IERROR1, IAD,
262 . IERROR,REQ_SB(NSPMD),
263 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
264 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
265 . REQ_RC(NSPMD),REQ_SC(NSPMD),
266 . INDEXI,ISINDEXI(NSPMD),INDEX(NUMNOD),NBOX(NSPMD),
267 . NBX,NBY,NBZ,IX,IY,IZ,
268 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5,
269 . RSIZ, ISIZ, L2, REQ_SD3(NSPMD),REQ_RD2(NSPMD),
270 . LEN2, RSHIFT, ISHIFT, ND, JDEB, Q, NBB
271
272 DATA msgoff/6000/
273 DATA msgoff2/6001/
274 DATA msgoff3/6002/
275 DATA msgoff4/6003/
276 DATA msgoff5/6004/
277
278 my_real
279 . bminma(6,nspmd),
280 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb
281
282 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
283 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
284 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAGNSNFI
285
286C-----------------------------------------------
287C S o u r c e L i n e s
288C-----------------------------------------------
289C
290C=======================================================================
291C tag of the boxes containing facets
292C and creation of candidates
293C=======================================================================
294 loc_proc = ispmd + 1
295
296 nbx = lrvoxel
297 nby = lrvoxel
298 nbz = lrvoxel
299C
300C Old value backup of the NSN Frontieres
301C
302 IF(inacti==5.OR.inacti==6.OR.inacti==7.OR.ifq>0
303 . .OR.num_imp>0.OR.itied/=0.OR.ityp==23.OR.ityp==24
304 . .OR.ityp==25) THEN
305 DO p = 1, nspmd
306 nsnfiold(p) = nsnfi(nin)%P(p)
307 END DO
308 END IF
309C
310C minmax box for sorting coming from i7buce BMINMA
311C
312 IF(ircvfrom(nin,loc_proc)==0.AND.
313 . isendto(nin,loc_proc)==0) RETURN
314 bminma(1,loc_proc) = bminmal(1)
315 bminma(2,loc_proc) = bminmal(2)
316 bminma(3,loc_proc) = bminmal(3)
317 bminma(4,loc_proc) = bminmal(4)
318 bminma(5,loc_proc) = bminmal(5)
319 bminma(6,loc_proc) = bminmal(6)
320C
321C Voxel shipment + min/max box
322C
323 IF(ircvfrom(nin,loc_proc)/=0) THEN
324 DO p = 1, nspmd
325 IF(isendto(nin,p)/=0) THEN
326 IF(p/=loc_proc) THEN
327 msgtyp = msgoff
328 CALL spmd_isend(
329 . crvoxel(0,0,loc_proc),
330 . (lrvoxel+1)*(lrvoxel+1),
331 .
332 . it_spmd(p),msgtyp,req_sc(p))
333 msgtyp = msgoff2
334 CALL spmd_isend(
335 . bminma(1,loc_proc),6 ,it_spmd(p),msgtyp,
336 . req_sb(p))
337 ENDIF
338 ENDIF
339 ENDDO
340 ENDIF
341C
342C Voxel reception + min-max boxes
343C
344 IF(isendto(nin,loc_proc)/=0) THEN
345 nbirecv=0
346 DO p = 1, nspmd
347 IF(ircvfrom(nin,p)/=0) THEN
348 IF(loc_proc/=p) THEN
349 nbirecv=nbirecv+1
350 irindexi(nbirecv)=p
351 msgtyp = msgoff
352 CALL spmd_irecv(
353 . crvoxel(0,0,p),
354 . (lrvoxel+1)*(lrvoxel+1),
355 . it_spmd(p),msgtyp,req_rc(nbirecv))
356 msgtyp = msgoff2
357 CALL spmd_irecv(
358 . bminma(1,p) ,6 ,it_spmd(p),msgtyp,
359 . req_rb(nbirecv))
360 ENDIF
361 ENDIF
362 ENDDO
363 ENDIF
364C
365C sending XREM
366C
367C computation of real and integer sending buffers sizes
368c general case
369 rsiz = 8
370 isiz = 6
371
372c specific cases
373c IGAP=1 or IGAP=2
374 IF(igap==1 .OR. igap==2)THEN
375 rsiz = rsiz + 1
376c IGAP=3
377 ELSEIF(igap==3)THEN
378 rsiz = rsiz + 2
379 ENDIF
380
381C thermic
382 IF(intth > 0 ) THEN
383 rsiz = rsiz + 2
384 isiz = isiz + 1
385 ENDIF
386
387C Interface Adhesion
388 IF(ityp==25.AND.ivis2==-1) THEN
389 IF(intth==0) rsiz = rsiz + 1 ! areas
390 isiz = isiz + 2 ! if_adh+ioldnsnfi
391 ENDIF
392
393C Friction
394 IF(intfric > 0 ) THEN
395 isiz = isiz + 1
396 ENDIF
397
398C -- IDTMINS==2
399 IF(idtmins == 2)THEN
400 isiz = isiz + 2
401C -- IDTMINS_INT /= 0
402 ELSEIF(idtmins_int/=0)THEN
403 isiz = isiz + 1
404 END IF
405
406c INT24
407 IF(ityp==24)THEN
408 rsiz = rsiz + 8
409 isiz = isiz + 3
410C-----for NBINFLG
411 IF (ilev==2) isiz = isiz + 1
412
413 ENDIF
414
415c INT25
416 IF(ityp==25)THEN
417 rsiz = rsiz + 3
418 isiz = isiz + 6
419C-----for NBINFLG
420 IF (ilev==2) isiz = isiz + 1
421 ENDIF
422
423 ideb = 1
424
425 jdeb = 0
426 IF(ityp==25)THEN
427 ALLOCATE(itagnsnfi(numnod),stat=ierror)
428 itagnsnfi(1:numnod) = 0
429 END IF
430
431 IF(isendto(nin,loc_proc)/=0) THEN
432 DO kk = 1, nbirecv
433 CALL spmd_waitany(nbirecv,req_rb,indexi)
434 p=irindexi(indexi)
435 CALL spmd_wait(req_rc(indexi))
436C Special treatment on d.d. keep only internal nodes
437 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
438 nod = fr_elem(j)
439C weight < 0 temporarily to keep only non-border nodes
440 weight(nod) = weight(nod)*(-1)
441 ENDDO
442C
443 l = ideb
444 nbox(p) = 0
445 nb = 0
446 xmaxb = bminma(1,p)
447 ymaxb = bminma(2,p)
448 zmaxb = bminma(3,p)
449 xminb = bminma(4,p)
450 yminb = bminma(5,p)
451 zminb = bminma(6,p)
452
453 DO i=1,nsn
454 nod = nsv(i)
455 IF(weight(nod)==1)THEN
456 IF(stifn(i)>zero)THEN
457 IF(itied/=0.AND.ityp==7.AND.candf_si(nin)%P(i)/=0) THEN
458 nb = nb + 1
459 index(nb) = i
460 ELSE
461 IF(x(1,nod) < xminb) cycle
462 IF(x(1,nod) > xmaxb) cycle
463 IF(x(2,nod) < yminb) cycle
464 IF(x(2,nod) > ymaxb) cycle
465 IF(x(3,nod) < zminb) cycle
466 IF(x(3,nod) > zmaxb) cycle
467
468 ix=int(nbx*(x(1,nod)-xminb)/(xmaxb-xminb))
469 IF(ix >= 0 .AND. ix <= nbx) THEN
470 iy=int(nby*(x(2,nod)-yminb)/(ymaxb-yminb))
471 IF(iy >= 0 .AND. iy <= nby) THEN
472 iz=int(nbz*(x(3,nod)-zminb)/(zmaxb-zminb))
473 IF(iz >= 0 .AND. iz <= nbz) THEN
474 IF(btest(crvoxel(iy,iz,p),ix)) THEN
475 nb = nb + 1
476 index(nb) = i
477 ENDIF
478 ENDIF
479 ENDIF
480 ENDIF
481 ENDIF
482 ENDIF
483 ENDIF
484 ENDDO
485 nbox(p) = nb
486C
487 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
488 nod = fr_elem(j)
489C resumption of weight > 0
490 weight(nod) = weight(nod)*(-1)
491 ENDDO
492C old tag
493 IF(ityp==25)THEN
494 jdeb = 0
495 DO q=1,p-1
496 jdeb = jdeb + nsnsi(nin)%P(q)
497 END DO
498 nbb = nsnsi(nin)%P(p)
499 DO j = 1, nbb
500 nd = nsvsi(nin)%P(jdeb+j)
501 nod= nsv(nd)
502 itagnsnfi(nod)=j
503 END DO
504 END IF
505C
506C Envoi taille msg
507C
508 msgtyp = msgoff3
509 CALL spmd_isend(nbox(p),1,it_spmd(p),msgtyp,
510 . req_sd(p))
511C
512C Alloc buffer
513C
514 IF (nb>0) THEN
515 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
516 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
517 IF(ierror/=0) THEN
518 CALL ancmsg(msgid=20,anmode=aninfo)
519 CALL arret(2)
520 ENDIF
521 l = 0
522 l2= 0
523
524 DO j = 1, nb
525 i = index(j)
526 nod = nsv(i)
527 rbuf(p)%p(l+1) = x(1,nod)
528 rbuf(p)%p(l+2) = x(2,nod)
529 rbuf(p)%p(l+3) = x(3,nod)
530 rbuf(p)%p(l+4) = v(1,nod)
531 rbuf(p)%p(l+5) = v(2,nod)
532 rbuf(p)%p(l+6) = v(3,nod)
533 rbuf(p)%p(l+7) = ms(nod)
534 rbuf(p)%p(l+8) = stifn(i)
535 ibuf(p)%p(l2+1) = i
536 ibuf(p)%p(l2+2) = itab(nod)
537 ibuf(p)%p(l2+3) = kinet(nod)
538! save specifics irem and xrem indexes for int24 sorting
539 ibuf(p)%p(l2+4) = 0 !IGAPXREMP
540 ibuf(p)%p(l2+5) = 0 !I24XREMP
541 ibuf(p)%p(l2+6) = 0 !I24IREMP
542 l = l + rsiz
543 l2 = l2 + isiz
544 END DO
545
546c shift for real variables (prepare for next setting)
547 rshift = 9
548c shift for integer variables (prepare for next setting)
549 ishift = 7
550
551c specific cases
552c IGAP=1 or IGAP=2
553 IF(igap==1 .OR. igap==2)THEN
554 l = 0
555 igapxremp = rshift
556 DO j = 1, nb
557 i = index(j)
558 rbuf(p)%p(l+rshift)= gap_s(i)
559 l = l + rsiz
560 ENDDO
561 rshift = rshift + 1
562
563c IGAP=3
564 ELSEIF(igap==3)THEN
565 l = 0
566 igapxremp = rshift
567 DO j = 1, nb
568 i = index(j)
569 rbuf(p)%p(l+rshift) = gap_s(i)
570 rbuf(p)%p(l+rshift+1)= gap_s_l(i)
571 l = l + rsiz
572 END DO
573 rshift = rshift + 2
574 ENDIF
575
576C thermic
577 IF(intth>0)THEN
578 l = 0
579 l2 = 0
580 DO j = 1, nb
581 i = index(j)
582 nod = nsv(i)
583 rbuf(p)%p(l+rshift) = temp(nod)
584 rbuf(p)%p(l+rshift+1) = areas(i)
585 ibuf(p)%p(l2+ishift) = ielec(i)
586 l = l + rsiz
587 l2 = l2 + isiz
588 END DO
589 rshift = rshift + 2
590 ishift = ishift + 1
591 ENDIF
592
593C Interface Adhesion
594 IF(ityp==25.AND.ivis2==-1)THEN
595 l = 0
596 l2 = 0
597 DO j = 1, nb
598 i = index(j)
599 nod = nsv(i)
600 IF(intth==0) rbuf(p)%p(l+rshift) = areas(i)
601 ibuf(p)%p(l2+ishift) = if_adh(i)
602 ibuf(p)%p(l2+ishift+1)=itagnsnfi(nod)
603 IF(intth==0) l = l + rsiz
604 l2 = l2 + isiz
605 END DO
606 IF(intth==0) rshift = rshift + 1
607 ishift = ishift + 2
608 ENDIF
609
610C Friction
611 IF(intfric>0)THEN
612 l2 = 0
613 DO j = 1, nb
614 i = index(j)
615 ibuf(p)%p(l2+ishift) = ipartfrics(i)
616 l2 = l2 + isiz
617 END DO
618 ishift = ishift + 1
619 ENDIF
620
621C -- IDTMINS==2
622 IF(idtmins==2)THEN
623 l2 = 0
624 DO j = 1, nb
625 i = index(j)
626 nod = nsv(i)
627 ibuf(p)%p(l2+ishift) = nodnx_sms(nod)
628 ibuf(p)%p(l2+ishift+1)= nod
629 l2 = l2 + isiz
630 END DO
631 ishift = ishift + 2
632
633C -- IDTMINS_INT /= 0
634 ELSEIF(idtmins_int/=0)THEN
635 l2 = 0
636 DO j = 1, nb
637 i = index(j)
638 nod = nsv(i)
639 ibuf(p)%p(l2+ishift)= nod
640 l2 = l2 + isiz
641 END DO
642 ishift = ishift + 1
643 ENDIF
644
645c INT24
646 IF(ityp==24)THEN
647
648 l = 0
649 i24xremp = rshift
650 DO j = 1, nb
651 i = index(j)
652 rbuf(p)%p(l+rshift) =i24_time_s(i)
653 rbuf(p)%p(l+rshift+1) =i24_frfi(1,i)
654 rbuf(p)%p(l+rshift+2) =i24_frfi(2,i)
655 rbuf(p)%p(l+rshift+3) =i24_frfi(3,i)
656 rbuf(p)%p(l+rshift+4) =i24_pene_old(1,i)
657 rbuf(p)%p(l+rshift+5) =i24_stif_old(1,i)
658 rbuf(p)%p(l+rshift+6) =i24_pene_old(3,i)
659 rbuf(p)%p(l+rshift+7) =i24_pene_old(5,i)
660 l = l + rsiz
661 END DO
662 rshift = rshift + 8
663
664 l2 = 0
665 i24iremp = ishift
666 DO j = 1, nb
667 i = index(j)
668C IRTLM(2,NSN) in TYPE24
669 ibuf(p)%p(l2+ishift) =irtlm(2*(i-1)+1)
670 ibuf(p)%p(l2+ishift+1)=irtlm(2*(i-1)+2)
671 ibuf(p)%p(l2+ishift+2)=i24_icont_i(i)
672 l2 = l2 + isiz
673 END DO
674 ishift = ishift + 3
675C---pay attention in i24sto.F IREM(I24IREMP+3,N-NSN) is used,
676C----change the shift value when new table was added like I24_ICONT_I
677 IF (ilev==2) THEN
678 l2 = 0
679 DO j = 1, nb
680 i = index(j)
681 ibuf(p)%p(l2+ishift)=nbinflg(i)
682 l2 = l2 + isiz
683 END DO
684 END IF
685 ishift = ishift + 1
686
687 END IF !(ITYP==24)
688
689c INT25
690 IF(ityp==25)THEN
691 l = 0
692 i24xremp = rshift
693 DO j = 1, nb
694 i = index(j)
695 rbuf(p)%p(l+rshift) =i24_time_s(2*(i-1)+1)
696 rbuf(p)%p(l+rshift+1) =i24_time_s(2*(i-1)+2)
697 rbuf(p)%p(l+rshift+2) =i24_pene_old(5,i) ! used only at time=0
698 l = l + rsiz
699 END DO
700 rshift = rshift + 3
701
702 l2 = 0
703 i24iremp = ishift
704
705 DO j = 1, nb
706 i = index(j)
707 nod = nsv(i)
708C IRTLM(3,NSN) in TYPE25 / IRTLM(3,-) useless here
709 ibuf(p)%p(l2+ishift) =irtlm(4*(i-1)+1)
710 ibuf(p)%p(l2+ishift+1)=irtlm(4*(i-1)+2)
711C
712C IRTLM(3,I) == local n of the impacted segment is shared but only valid on proc == IRTLM(4,I)
713 ibuf(p)%p(l2+ishift+2)=irtlm(4*(i-1)+3)
714 ibuf(p)%p(l2+ishift+3)=irtlm(4*(i-1)+4)
715 ibuf(p)%p(l2+ishift+4)=i24_icont_i(i)
716 ibuf(p)%p(l2+ishift+5)=itagnsnfi(nod)
717 l2 = l2 + isiz
718 END DO
719 ishift = ishift + 6
720C---pay attention in i25sto.F IREM(I24IREMP+4,N-NSN) is used,
721C----change the shift value when new table was added like IRTLM(3*(I-1)+2)
722 IF (ilev==2) THEN
723 l2 = 0
724 DO j = 1, nb
725 i = index(j)
726 ibuf(p)%p(l2+ishift)=nbinflg(i)
727 l2 = l2 + isiz
728 END DO
729 END IF
730 ishift = ishift + 1
731
732 END IF !(ITYP==25)
733C
734 !save specifics IREM and XREM indexes for INT24 sorting
735 l2 = 0
736 DO j = 1, nb
737 i = index(j)
738 nod = nsv(i)
739 !save specifics IREM and XREM indexes for INT24 sorting
740 ibuf(p)%p(l2+4) = igapxremp
741 ibuf(p)%p(l2+5) = i24xremp
742 ibuf(p)%p(l2+6) = i24iremp
743 l2 = l2 + isiz
744 END DO
745
746 msgtyp = msgoff4
747
748 CALL spmd_isend(
749 1 rbuf(p)%P(1),nb*rsiz,it_spmd(p),msgtyp,
750 2 req_sd2(p))
751
752 msgtyp = msgoff5
753 CALL spmd_isend(
754 1 ibuf(p)%P(1),nb*isiz,it_spmd(p),msgtyp,
755 2 req_sd3(p))
756
757 ENDIF
758C
759C reset old tag for next P
760 IF(ityp==25)THEN
761 nbb = nsnsi(nin)%P(p)
762 DO j = 1, nbb
763 nd = nsvsi(nin)%P(jdeb+j)
764 nod= nsv(nd)
765 itagnsnfi(nod)=0
766 END DO
767 END IF
768 ENDDO
769 ENDIF
770C
771 IF(ityp==25) DEALLOCATE(itagnsnfi)
772C
773C reception of XREM data
774C
775 IF(ircvfrom(nin,loc_proc)/=0) THEN
776 nsnr = 0
777 l=0
778 DO p = 1, nspmd
779 nsnfi(nin)%P(p) = 0
780 IF(isendto(nin,p)/=0) THEN
781 IF(loc_proc/=p) THEN
782 msgtyp = msgoff3
783 CALL spmd_recv(nsnfi(nin)%P(p),1,it_spmd(p),
784 . msgtyp)
785 IF(nsnfi(nin)%P(p)>0) THEN
786 l=l+1
787 isindexi(l)=p
788 nsnr = nsnr + nsnfi(nin)%P(p)
789 ENDIF
790 ENDIF
791 ENDIF
792 ENDDO
793 nbirecv=l
794C
795C Allocate total size
796C
797 IF(nsnr>0) THEN
798
799 ALLOCATE(xrem(rsiz,nsnr),stat=ierror)
800 ALLOCATE(irem(isiz,nsnr),stat=ierror)
801
802 IF(ierror/=0) THEN
803 CALL ancmsg(msgid=20,anmode=aninfo)
804 CALL arret(2)
805 ENDIF
806 ideb = 1
807 DO l = 1, nbirecv
808 p = isindexi(l)
809 len = nsnfi(nin)%P(p)*rsiz
810 msgtyp = msgoff4
811
812 CALL spmd_irecv(
813 1 xrem(1,ideb),len,it_spmd(p),
814 2 msgtyp,req_rd(l))
815
816 len2 = nsnfi(nin)%P(p)*isiz
817 msgtyp = msgoff5
818 CALL spmd_irecv(
819 1 irem(1,ideb),len2,it_spmd(p),
820 2 msgtyp,req_rd2(l))
821 ideb = ideb + nsnfi(nin)%P(p)
822 ENDDO
823 DO l = 1, nbirecv
824 CALL spmd_waitany(nbirecv,req_rd,indexi)
825 CALL spmd_waitany(nbirecv,req_rd2,indexi)
826 ENDDO
827
828 !set specifics IREM and XREM indexes for INT24 sorting
829 igapxremp = irem(4,1)
830 i24xremp = irem(5,1)
831 i24iremp = irem(6,1)
832 ENDIF
833 ENDIF
834C
835 IF(ircvfrom(nin,loc_proc)/=0) THEN
836 DO p = 1, nspmd
837 IF(isendto(nin,p)/=0) THEN
838 IF(p/=loc_proc) THEN
839 CALL spmd_wait(req_sb(p))
840 CALL spmd_wait(req_sc(p))
841 ENDIF
842 ENDIF
843 ENDDO
844 ENDIF
845C
846 IF(isendto(nin,loc_proc)/=0) THEN
847 DO p = 1, nspmd
848 IF(ircvfrom(nin,p)/=0) THEN
849 IF(p/=loc_proc) THEN
850 CALL spmd_wait(req_sd(p))
851 IF(nbox(p)/=0) THEN
852 CALL spmd_wait(req_sd2(p))
853 DEALLOCATE(rbuf(p)%p)
854 CALL spmd_wait(req_sd3(p))
855 DEALLOCATE(ibuf(p)%p)
856 END IF
857 ENDIF
858 ENDIF
859 ENDDO
860 ENDIF
861C
862C
863#endif
864 RETURN
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
tri7box::nsvsi
type(int_pointer), dimension(:), allocatable nsvsi
Definition tri7box.F:485
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491

◆ spmd_tri7vox0()

subroutine spmd_tri7vox0 ( x,
bminmal,
integer igap,
integer nrtm,
stf,
tzinf,
curv_max,
gapmin,
gapmax,
gap_m,
integer, dimension(4,*) irect,
gap,
bgapsmx,
intent(in) drad,
intent(in) dgapload )

Definition at line 54 of file spmd_int.F.

58C-----------------------------------------------
59C M o d u l e s
60C-----------------------------------------------
61 USE tri7box
62 USE spmd_mod
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66#include "implicit_f.inc"
67#include "comlock.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "task_c.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER IGAP, NRTM, IRECT(4,*)
76 my_real
77 . x(3,*), bminmal(*),
78 . stf(*), gap_m(*), bgapsmx,
79 . tzinf,gapmin,gapmax,gap,curv_max(nrtm)
80 my_real , INTENT(IN) :: drad,dgapload
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER LOC_PROC,
85 . NBX,NBY,NBZ,NE,M1,M2,M3,M4,
86 . IX1,IY1,IZ1,IX2,IY2,IZ2,IX,IY,IZ
87 my_real
88 . ratio, aaa, marge,
89 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
90 . xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,
91 . xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4
92c DATA IPWR2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,
93c . 16384,32768,65536,131072,262144,524288,1048576,
94c . 2097152,4194304,8388608,16777216,33554432,67108864,
95c . 134217728,268435456,536870912,1073741824,2147483648/
96 INTEGER TMP
97C-----------------------------------------------
98C S o u r c e L i n e s
99C-----------------------------------------------
100C
101C=======================================================================
102C tag of the boxes containing facets
103C and creation of candidates
104C=======================================================================
105
106 loc_proc = ispmd + 1
107 marge = tzinf-max(gap+dgapload,drad)
108
109 nbx = lrvoxel
110 nby = lrvoxel
111 nbz = lrvoxel
112
113 xmaxb = bminmal(1)
114 ymaxb = bminmal(2)
115 zmaxb = bminmal(3)
116 xminb = bminmal(4)
117 yminb = bminmal(5)
118 zminb = bminmal(6)
119
120 DO ne=1,nrtm
121C We do not retain the Destruit facets
122 IF(stf(ne) == zero)cycle
123
124 IF(igap == 0)THEN
125 aaa = tzinf+curv_max(ne)
126 ELSE
127 aaa = marge+curv_max(ne)+
128 . max(min(gapmax,max(gapmin,bgapsmx+gap_m(ne)))+dgapload,drad)
129 ENDIF
130
131c It is possible to improve the algo by cutting the facet
132c in 2 (4,3,6,9 ...) if the facet is large in front of AAA and inclinee
133
134 m1 = irect(1,ne)
135 m2 = irect(2,ne)
136 m3 = irect(3,ne)
137 m4 = irect(4,ne)
138
139 xx1=x(1,m1)
140 xx2=x(1,m2)
141 xx3=x(1,m3)
142 xx4=x(1,m4)
143 xmaxe=max(xx1,xx2,xx3,xx4)
144 xmine=min(xx1,xx2,xx3,xx4)
145
146 yy1=x(2,m1)
147 yy2=x(2,m2)
148 yy3=x(2,m3)
149 yy4=x(2,m4)
150 ymaxe=max(yy1,yy2,yy3,yy4)
151 ymine=min(yy1,yy2,yy3,yy4)
152
153 zz1=x(3,m1)
154 zz2=x(3,m2)
155 zz3=x(3,m3)
156 zz4=x(3,m4)
157 zmaxe=max(zz1,zz2,zz3,zz4)
158 zmine=min(zz1,zz2,zz3,zz4)
159
160c index of the voxels occupied by the facet
161
162 ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
163 iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
164 iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
165
166 ix1=max(0,min(nbx,ix1))
167 iy1=max(0,min(nby,iy1))
168 iz1=max(0,min(nbz,iz1))
169
170 ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
171 iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
172 iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
173
174 ix2=max(0,min(nbx,ix2))
175 iy2=max(0,min(nby,iy2))
176 iz2=max(0,min(nbz,iz2))
177
178 DO iz = iz1, iz2
179 DO iy = iy1, iy2
180 tmp = 0
181 DO ix = ix1, ix2
182 tmp=ibset(tmp,ix)
183 END DO
184!$OMP ATOMIC
185 crvoxel(iy,iz,loc_proc)=ior(crvoxel(iy,iz,loc_proc),tmp)
186 END DO
187 END DO
188 ENDDO
189
190C
191 RETURN