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 3548 of file spmd_int.F.

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

◆ 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 3927 of file spmd_int.F.

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

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

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

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

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

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

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

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

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

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