Télécharger la plaquette Cast3M


fr en

Télécharger nlocsb.eso

Retour à la liste

Numérotation des lignes : 

nlocsb

  1. C NLOCSB    SOURCE    AM        17/11/29    21:15:03     9635           
  2. C_______________________________________________________________________
  3. C
  4. C           CALCUL DE LA MOYENNE NONLOCALE BASEE SUR L'ETAT DE CONTRAINTE
  5. C
  6. C
  7. C    Entrees:
  8. C    ________
  9. C
  10. C           IPCHI  Pointeur sur un MCHAML de ss-type indifferent
  11. C           IPLMOT Pointeur sur un LISTMOTS de noms de composante
  12. C
  13. C           IPCHCO Pointeur sur un MCHAML de Connectivite
  14. C                  (ss-type CONNECTIVITE NON LOCAL)
  15. C
  16. C    Sorties:
  17. C    ________
  18. C
  19. C           IPCHO  Pointeur sur un MCHAML de meme ss-type que IPCHI
  20. C                  avec les composantes IPLMOT moyennees
  21. C                  les composantes non reconnues dans iplmot sont
  22. C                  recopiees
  23. C
  24. C           IRET   1 ou 0 suivant succes ou pas
  25. C
  26. C
  27. C     Appele par: NLOCAL
  28. C     -----------
  29. C
  30. C     Appel a:
  31. C     --------
  32. C
  33. C           NLOVEP verification et preparation de la moyenne
  34. C           TRTRVE point translate
  35. C           TRSYPT point symetrique par rapport a un point
  36. C           TRSYDR point symetrique par rapport a une droite
  37. C           TRSYPL point symetrique par rapport a un plan
  38. C           DOXE, JACOBI
  39. C
  40. C   C.GIRY F.DUFOUR VERSION PRENANT EN COMPTE L'ETAT DE CONTRAINTE
  41. C   SEPTEMBRE 2010
  42. C
  43. C   NONLOCAL ORIGINAL
  44. C   P.PEGON OCTOBRE 92 D'APRES C. LA BORDERIE AVRIL 1992 D'APRES P. PEGON
  45. C_______________________________________________________________________
  46. C
  47.       SUBROUTINE NLOCSB(IPCHI,IPLMOT,IPCHCO, IPCHO, IRET)
  48.  
  49.       IMPLICIT INTEGER(I-N)
  50.       IMPLICIT REAL*8(A-H,O-Z)
  51. C
  52. -INC PPARAM
  53. -INC CCOPTIO
  54. C
  55. -INC SMMODEL
  56. -INC SMELEME
  57. -INC SMCOORD
  58. -INC SMCHAML
  59. -INC SMLENTI
  60. -INC SMLREEL
  61. -INC SMLMOTS
  62. -INC SMINTE
  63. -INC CCREEL
  64.  
  65.       SEGMENT,WRK1
  66.         REAL*8 XE(3,NBNN)
  67.       ENDSEGMENT
  68. *
  69.       SEGMENT NLOC1
  70.         INTEGER ILOC2 (NZONEF)
  71.       END SEGMENT
  72. *
  73.       SEGMENT NLOC2
  74.         INTEGER MPCHAM (NDOUBL)
  75.         INTEGER ILOC4  (NDOUBL)
  76.         INTEGER MODLAC,MAILEF,MINTEF
  77.         INTEGER MAILAC (NSZACC)
  78.         INTEGER MINTAC (NSZACC)
  79.         INTEGER ILOC3  (NSZACC)
  80.         INTEGER ILOC3I,ILOC3O
  81.         INTEGER MELCAR
  82.       END SEGMENT
  83. *
  84.       SEGMENT NLOC3
  85.         INTEGER     MELVAC (NCOMP)
  86.       END SEGMENT
  87. *
  88.       SEGMENT NLOC4
  89.         INTEGER JCLE
  90.         REAL*8 PT1(3),PT2(3),DISP
  91.         INTEGER MELPNI,MELPLI
  92.       END SEGMENT
  93. *
  94.       SEGMENT,WRK2
  95.         REAL*8 XEJ(3,NBNJ),SHP(6,NBNJ)
  96.       ENDSEGMENT
  97. *
  98.       SEGMENT WRK3
  99.         REAL*8 SOMCOM(NCOMP,NBPGAU)
  100.         REAL*8 SOMJAC(      NBPGAU)
  101.       END SEGMENT
  102. *
  103.       POINTEUR MLCOMP.MLENTI
  104.       POINTEUR MLNIMO.MLENTI
  105. C
  106.       DIMENSION XXX(3),XXXJ(3),XXXV1(3),XXXV2(3),XXXV3(3),PTO(3)
  107. C
  108.       DATA XMULTL/1.5/
  109. C
  110.       REAL*8 N2VEC2,NVEC2
  111.       REAL*8 N2VECPO2,NVECPO2
  112. C
  113.       NHRM=NIFOUR
  114.       IRET=1
  115. C
  116. C     ON VERIFIE/PREPARE LES DONNEES
  117. C
  118.       CALL NLOVEP(IPCHCO,IPCHI, IPCHO,NLOC1,IRET)
  119.       IF (IRET.EQ.0) RETURN
  120. C
  121. C     ON TRAITE L'INFORMATION
  122. C
  123. C     BOUCLE SUR LES ZONES EFFECTIVES
  124. C
  125.       NZONEF=ILOC2(/1)
  126. C
  127.       DO ISOUCF=1,NZONEF
  128. C
  129. C     write(IOIMP,*)'ZONE EFFECTIVE',ISOUCF
  130.          NLOC2=ILOC2(ISOUCF)
  131.          MINTE1=MINTEF
  132.          IPT1=MAILEF
  133.          NDOUBL=ILOC4(/1)
  134.          NLOC3=ILOC3I
  135.          NCOMP=MELVAC(/1)
  136. C
  137. C     NOMBRE DE POINTS DE GAUSS PAR ELEMENTS POUR LA SS ZONE A MOYENNER
  138. C
  139.          NBPGAU=MINTE1.POIGAU(/1)
  140. C
  141. C     NOMBRE D'ELEMENTS ET DE NOEUDS POUR LA SS ZONE A MOYENNER
  142. C
  143.          NBELEM=IPT1.NUM(/2)
  144.          NBNN  =IPT1.NUM(/1)
  145.          SEGINI WRK1
  146.          SEGINI WRK3
  147. C
  148. C     DEBUT DE LA BOUCLE SUR LES ELEMENTS
  149. C
  150.          DO IB=1,NBELEM
  151. C     write(IOIMP,*)' ELEMENT NUMERO',IB
  152. C
  153. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  154. C
  155.            CALL DOXE(XCOOR,IDIM,NBNN,IPT1.NUM,IB,XE)
  156. C
  157. C      INITIALISATION DES DIVERSES INTEGRATIONS
  158. C
  159.            DO IGAU=1,NBPGAU
  160.              SOMJAC(IGAU)=0.D0
  161.              DO IE1=1,NCOMP
  162.                SOMCOM(IE1,IGAU)=0.D0
  163.              END DO
  164.            END DO
  165. C
  166. C     ON BOUCLE SUR LES DOUBLONS
  167. C
  168.            DO IDOUBL=1,NDOUBL
  169.              NLOC4=ILOC4(IDOUBL)
  170.              ICLE=JCLE
  171. C
  172. C    ON RECUPERE LE NUMERO D'ORDRE DES SOUS ZONES ACCESSIBLES
  173. C
  174.              MELVAL=MELPNI
  175.              MLNIMO=IELCHE(1,IB)
  176. C     write(IOIMP,*)'  DOUBLON ICLE MLNIMO ',IDOUBL,ICLE,MLNIMO
  177. C
  178. C    CET ELEMENT EST IL EN CONNECTIVITE ?
  179. C
  180.              IF (MLNIMO.NE.0)THEN
  181.                SEGACT,MLNIMO
  182. C
  183. C     ON RECUPERE LA LISTE DES ELEMENTS  ACCESSIBLES DANS
  184. C     LE CHAMELEM DE CONNECTIVITE
  185. C
  186.                MELVAL=MELPLI
  187.                MLENTI=IELCHE(1,IB)
  188.                SEGACT,MLENTI
  189. C
  190. C   ON CREE UN MLENT1 QUI PERMETTRA DE TROUVER LE DEBUT DE L'INFORMATION
  191. C   CONCERNANT CHAQUE SS ZONE
  192. C
  193.                JG=1
  194.                SEGINI MLENT1
  195.                MLENT1.LECT(1)=1
  196.                NSOUSA=MLNIMO.LECT(/1)
  197.                IF (NSOUSA.GT.1)THEN
  198.                  DO IISOUJ=2,NSOUSA
  199.                    JG=MLENT1.LECT(/1)+1
  200.                    SEGADJ MLENT1
  201.                    MLENT1.LECT(JG)=MLENT1.LECT(JG-1)+
  202.      1                             LECT(MLENT1.LECT(JG-1))+1
  203.                  END DO
  204.                ENDIF
  205. C
  206. C     DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
  207. C
  208.                DO IGAU=1,NBPGAU
  209. C
  210. C     ON RECUPERE LA LONGUEUR CARACTERISTIQUE
  211. C
  212.                  MELVAL=MELCAR
  213.                  XLONG=VELCHE(MIN(IGAU,VELCHE(/1)),MIN(IB,VELCHE(/2)))
  214. C     write(IOIMP,*)'   GAUSS-P,XLONG ',IGAU,XLONG
  215. C
  216. C     ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
  217. C
  218.                  DO IE1=1,3
  219.                    r_z = 0.D0
  220.                    DO IE2=1,NBNN
  221.                      r_z=r_z+XE(IE1,IE2)*MINTE1.SHPTOT(1,IE2,IGAU)
  222.                    END DO
  223.                    XXX(IE1)=r_z
  224.                  END DO
  225. C     write(IOIMP,*)'   XXX ',XXX
  226. C
  227. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
  228. C
  229.                  DO IISOUJ=1,NSOUSA
  230.                    IISOUS=MLNIMO.LECT(IISOUJ)
  231.                    NLOC3=ILOC3(IISOUS)
  232.                    IPT2=MAILAC(IISOUS)
  233.                    MINTE2=MINTAC(IISOUS)
  234. C
  235.                    NBPGAJ=MINTE2.POIGAU(/1)
  236.                    NBNJ  =IPT2.NUM(/1)
  237. C
  238.                    IG1=MLENT1.LECT(IISOUJ)
  239.                    NBELEJ=LECT(IG1)
  240. C     write(IOIMP,*)'    ZONES-AC,IISOUS ',IISOUJ,IISOUS
  241. C
  242. C     DEBUT DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
  243. C
  244.                    SEGINI,WRK2
  245.                    DO IIBJ=1,NBELEJ
  246.                      IG1=IG1+1
  247.                      IBJ=LECT(IG1)
  248. C     write(IOIMP,*)'     ELEMENT_AC ',IBJ
  249. C
  250. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IIBJ
  251. C
  252.                      CALL DOXE(XCOOR,IDIM,NBNJ,IPT2.NUM,IBJ,XEJ)
  253. C
  254. C     DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
  255. C
  256.                      DO IGAUJ=1,NBPGAJ
  257. C
  258. C      ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
  259. C
  260.                        DO IE1=1,3
  261.                          r_z = 0.D0
  262.                          DO IE2=1,NBNJ
  263.                           r_z = r_z + XEJ(IE1,IE2) *
  264.      &                                MINTE2.SHPTOT(1,IE2,IGAUJ)
  265.                          END DO
  266.                          XXXJ(IE1)=r_z
  267.                        END DO
  268. C     write(IOIMP,*)'      GAUSS-AC ',IGAUJ
  269. C     write(IOIMP,*)'      XXXJ-AS ',XXXJ
  270. C
  271. C     ON TRANSFORME CES COORDONNEES EN FONCTION DES SYMETRIE OU DE LA
  272. C     TRANSLATION
  273. C
  274. C+CG
  275. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  276. C
  277. C  MODIFICATIONS POUR LA SYMMETRIE
  278. C
  279. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  280.                        DO IE1=1,3
  281.                          PTO(IE1)=0.D0
  282.                          PTO(IE1)=0.D0
  283.                          PTO(IE1)=0.D0
  284.                        END DO
  285.                        DZERO=0.D0
  286.                        IF(ICLE.EQ.2)CALL TRTRVE(XXXJ,1,PT1     )
  287.                        IF(ICLE.EQ.3)CALL TRSYPT(XXXJ,1,PT1     )
  288.                        IF(ICLE.EQ.4)CALL TRSYDR(XXXJ,1,PT1,PT2 )
  289.                        IF(ICLE.EQ.5)CALL TRSYPL(XXXJ,1,PT1,DISP)
  290. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  291. C                       write(IOIMP,*)'      XXXJ-PS ',XXXJ
  292. C
  293. C      ON REMPLIT LES SHP
  294. C
  295.                        DO IE1=1,6
  296.                          DO IE2=1,NBNJ
  297.                            SHP(IE1,IE2)=MINTE2.SHPTOT(IE1,IE2,IGAUJ)
  298.                          END DO
  299.                        END DO
  300. C
  301. C      ON CALCULE LE JACOBIEN
  302. C
  303.                        CALL JACOBI(XEJ,SHP,IDIM,NBNJ,DJAC)
  304. C
  305. C      ON CALCULE LA VALEUR DE LA GAUSSIENNE
  306. C
  307. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  308. C
  309. C  NONLOCAL BASE SUR L'ETAT DE CONTRAINTE
  310. C  CG FD
  311. C
  312. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  313. C        CHAMP PIC TRACTION FT
  314. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  315.                        MELVAL=MELVAC(14)
  316.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  317.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  318.                        FT1 = VELCHE(IGMN,IBMN)
  319. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  320. C        CHAMP TAILLE MINIMALE ELEMENT
  321. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  322.                        MELVAL=MELVAC(15)
  323.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  324.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  325.                        TAL1 = VELCHE(IGMN,IBMN)
  326.                        TAI1 = TAL1
  327. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  328. C        CONTRAINTE PRINCIPALE I
  329. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  330.                        MELVAL=MELVAC(2)
  331.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  332.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  333.                        COEFI=VELCHE(IGMN,IBMN)
  334.                        COEFIB=FT1*TAI1/XLONG
  335.                        IF(ABS(COEFI).LE.COEFIB) THEN
  336.                        COEFI=COEFIB
  337.                        ENDIF
  338. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  339. C        VECTEUR PRINCIPAL I
  340. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  341.                        MELVAL=MELVAC(5)
  342.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  343.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  344.                        COX1=VELCHE(IGMN,IBMN)
  345.                        MELVAL=MELVAC(6)
  346.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  347.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  348.                        COY1=VELCHE(IGMN,IBMN)
  349.                        MELVAL=MELVAC(7)
  350.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  351.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  352.                        COZ1=VELCHE(IGMN,IBMN)
  353.                        IF(ICLE.EQ.4) THEN
  354.                        XXXV1(1)=COX1
  355.                        XXXV1(2)=COY1
  356.                        XXXV1(3)=COZ1
  357.                        CALL TRSYDR(XXXV1,1,PTO,PT2)
  358.                        COX1=XXXV1(1)
  359.                        COY1=XXXV1(2)
  360.                        COZ1=XXXV1(3)
  361.                        ENDIF
  362.                        IF(ICLE.EQ.5) THEN
  363.                        XXXV1(1)=COX1
  364.                        XXXV1(2)=COY1
  365.                        XXXV1(3)=COZ1
  366.                        CALL TRSYPL(XXXV1,1,PT1,DZERO)
  367.                        COX1=XXXV1(1)
  368.                        COY1=XXXV1(2)
  369.                        COZ1=XXXV1(3)
  370.                        ENDIF
  371. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  372. C        CONTRAINTE PRINCIPALE II
  373. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  374.                        MELVAL=MELVAC(3)
  375.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  376.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  377.                        COEFJ=VELCHE(IGMN,IBMN)
  378.                        COEFJB=FT1*TAI1/XLONG
  379.                        IF(ABS(COEFJ).LE.COEFJB) THEN
  380.                        COEFJ=COEFJB
  381.                        ENDIF
  382. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  383. C        VECTEUR PRINCIPAL II
  384. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  385.                        MELVAL=MELVAC(8)
  386.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  387.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  388.                        COX2=VELCHE(IGMN,IBMN)
  389.                        MELVAL=MELVAC(9)
  390.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  391.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  392.                        COY2=VELCHE(IGMN,IBMN)
  393.                        MELVAL=MELVAC(10)
  394.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  395.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  396.                        COZ2=VELCHE(IGMN,IBMN)
  397.                        IF(ICLE.EQ.4) THEN
  398.                        XXXV2(1)=COX2
  399.                        XXXV2(2)=COY2
  400.                        XXXV2(3)=COZ2
  401.                        CALL TRSYDR(XXXV2,1,PTO,PT2)
  402.                        COX2=XXXV2(1)
  403.                        COY2=XXXV2(2)
  404.                        COZ2=XXXV2(3)
  405.                        ENDIF
  406.                        IF(ICLE.EQ.5) THEN
  407.                        XXXV2(1)=COX2
  408.                        XXXV2(2)=COY2
  409.                        XXXV2(3)=COZ2
  410.                        CALL TRSYPL(XXXV2,1,PT1,DZERO)
  411.                        COX2=XXXV2(1)
  412.                        COY2=XXXV2(2)
  413.                        COZ2=XXXV2(3)
  414.                        ENDIF
  415. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  416. C        CONTRAINTE PRINCIPALE III
  417. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  418.                        MELVAL=MELVAC(4)
  419.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  420.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  421.                        COEFK=VELCHE(IGMN,IBMN)
  422.                        COEFKB=FT1*TAI1/XLONG
  423.                        IF(ABS(COEFK).LE.COEFKB) THEN
  424.                        COEFK=COEFKB
  425.                        ENDIF
  426. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  427. C        VECTEUR PRINCIPAL III
  428. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  429.                        MELVAL=MELVAC(11)
  430.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  431.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  432.                        COX3=VELCHE(IGMN,IBMN)
  433.                        MELVAL=MELVAC(12)
  434.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  435.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  436.                        COY3=VELCHE(IGMN,IBMN)
  437.                        MELVAL=MELVAC(13)
  438.                        IBMN=MIN(IBJ  ,VELCHE(/2))
  439.                        IGMN=MIN(IGAUJ,VELCHE(/1))
  440.                        COZ3=VELCHE(IGMN,IBMN)
  441.                        IF(ICLE.EQ.4) THEN
  442.                        XXXV3(1)=COX3
  443.                        XXXV3(2)=COY3
  444.                        XXXV3(3)=COZ3
  445.                        CALL TRSYDR(XXXV3,1,PTO,PT2)
  446.                        COX3=XXXV3(1)
  447.                        COY3=XXXV3(2)
  448.                        COZ3=XXXV3(3)
  449.                        ENDIF
  450.                        IF(ICLE.EQ.5) THEN
  451.                        XXXV3(1)=COX3
  452.                        XXXV3(2)=COY3
  453.                        XXXV3(3)=COZ3
  454.                        CALL TRSYPL(XXXV3,1,PT1,DZERO)
  455.                        COX3=XXXV3(1)
  456.                        COY3=XXXV3(2)
  457.                        COZ3=XXXV3(3)
  458.                        ENDIF
  459. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  460. C        CALCUL DE L'ANGLE ENTRE U1 ET (X-S)u1u2
  461. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  462.                        VEC11=((XXX(2)-XXXJ(2))*COZ3)-
  463.      1                 ((XXX(3)-XXXJ(3))*COY3)
  464.                        VEC12=((XXX(3)-XXXJ(3))*COX3)-
  465.      1                 ((XXX(1)-XXXJ(1))*COZ3)
  466.                        VEC13=((XXX(1)-XXXJ(1))*COY3)-
  467.      1                 ((XXX(2)-XXXJ(2))*COX3)
  468.                        VEC21=(COY3*VEC13)- (COZ3*VEC12)
  469.                        VEC22=(COZ3*VEC11)- (COX3*VEC13)
  470.                        VEC23=(COX3*VEC12)- (COY3*VEC11)
  471.                        N2VEC2=(VEC21**2)+(VEC22**2)+(VEC23**2)
  472.                        NVEC2=SQRT(N2VEC2)
  473.                        CTETA=((COX1*VEC21)+(COY1*VEC22)+(COZ1*VEC23))
  474.      1                  /(NVEC2 +10.E-10)
  475.                        STETA=((COX2*VEC21)+(COY2*VEC22)+(COZ2*VEC23))
  476.      1                  /(NVEC2 +10.E-10)
  477. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  478. C        CALCUL DE L'ANGLE ENTRE U3 ET (X-S)
  479. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  480.                        VECPO1=(XXX(1)-XXXJ(1))
  481.                        VECPO2=(XXX(2)-XXXJ(2))
  482.                        VECPO3=(XXX(3)-XXXJ(3))
  483.                        N2VECPO2=(VECPO1**2)+(VECPO2**2)+(VECPO3**2)
  484.                        NVECPO2=SQRT(N2VECPO2)
  485.                        CPHI=((COX3*VECPO1)+(COY3*VECPO2)+(COZ3*VECPO3))
  486.      1                  /(NVECPO2 +10.E-10)
  487.                        SPHI=((VECPO1*VEC21)+(VECPO2*VEC22)+
  488.      1                  (VECPO3*VEC23))/((NVEC2*NVECPO2) +10.E-10)
  489. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  490. C        CORRECTION POUR PRENDRE EN COMPTE LE CAS OU SEUL SIGMA1 EST NON
  491. C        NUL
  492. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  493.                        XXLONG1=XLONG*COEFI/FT1
  494.                        XXLONG2=XLONG*COEFJ/FT1
  495.                        XXLONG3=XLONG*COEFK/FT1
  496. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  497. C        CALCUL DU RAYON D'INTERACTION
  498. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  499.                       COEF1=((SPHI**2)*(CTETA**2))/(XXLONG1**2)
  500.                       COEF2=((SPHI**2)*(STETA**2))/(XXLONG2**2)
  501.                       COEF3=(CPHI**2)/(XXLONG3**2)
  502.                       PHOLC=(COEF1+COEF2+COEF3)
  503.                       if (abs(pholc).lt.xpetit) pholc=xpetit
  504.                       PHOLC=(1)/pholc
  505.                       IF(PHOLC.GE.XLONG)THEN
  506.                          PHOLC=XLONG
  507.                       ENDIF
  508. C     write(IOIMP,*)'      XXLONG,DJAC ',XXLONG,DJAC
  509. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  510. C        SELECTION D'UNE ZONE AUTOUR DU POINT DE GAUSS
  511. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  512.                        IF(NVECPO2.LE.XMULTL*XLONG)THEN
  513.                          GDEX=EXP(-(2*NVECPO2)**2/PHOLC )
  514.                          DJAC=MINTE2.POIGAU(IGAUJ)*GDEX*ABS(DJAC)
  515. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  516. C modif NCOMP
  517.                          DO IE1=1,1
  518.                            MELVAL=MELVAC(IE1)
  519. C
  520. C              ON DOIT RETROUVER LE NUMERO D'ELEMENT ATTACHE AU CHAMELEM
  521. C              CORRESPONDANT A CELUI DU MELEME
  522. C
  523.                            IBMN=MIN(IBJ  ,VELCHE(/2))
  524.                            IGMN=MIN(IGAUJ,VELCHE(/1))
  525.                            SOMCOM(IE1,IGAU)=SOMCOM(IE1,IGAU)
  526.      1                                    +VELCHE(IGMN,IBMN)*DJAC
  527. C     write(IOIMP,*)'      VELCHE,DJAC ',VELCHE(IGMN,IBMN),DJAC
  528.                          END DO
  529.                          SOMJAC(IGAU)=SOMJAC(IGAU)+DJAC
  530.                        ENDIF
  531. C
  532. C     FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
  533. C
  534.                      END DO
  535. C
  536. C     FIN DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
  537. C
  538.                    END DO
  539. C
  540.                    SEGSUP,WRK2
  541. C
  542. C     FIN DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
  543. C
  544.                  END DO
  545. C
  546. C     FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
  547. C
  548.                END DO
  549.                SEGDES MLENTI
  550.                SEGDES MLNIMO
  551.                SEGSUP MLENT1
  552. C
  553. C     FIN DU TEST D'EXISTENCE DE CONNECTIVITE SUR L'ELEMENT
  554. C
  555.              ENDIF
  556. C
  557. C     FIN DE LA BOUCLE SUR LES DOUBLONS
  558. C
  559.            END DO
  560. C
  561.            NLOC3=ILOC3O
  562.            DO IE1=1,1
  563.              MELVAL=MELVAC(IE1)
  564.              SEGACT MELVAL*MOD
  565.              DO IGAU=1,NBPGAU
  566.                VELCHE(IGAU,IB)=SOMCOM(IE1,IGAU)/SOMJAC(IGAU)
  567.              END DO
  568.            END DO
  569. C
  570. C     FIN DE LA BOUCLE SUR LES ELEMENTS
  571. C
  572.          END DO
  573. C
  574.          SEGSUP WRK1,WRK3
  575. C
  576. C     FIN DE LA BOUCLE SUR LES SOUS ZONES EFFECTIVES
  577. C
  578.       END DO
  579. C
  580. C      DESACTIVATIONS/SUPRESSION
  581. C      WARNING SUR LES DOUBLONS DE MODEL!
  582. C
  583.       DO IZONEF=1,NZONEF
  584.         NLOC2=ILOC2(IZONEF)
  585.         NDOUBL=ILOC4(/1)
  586.         DO IDOUBL=1,NDOUBL
  587.           NLOC4=ILOC4(IDOUBL)
  588.           MELVAL=MELPNI
  589.           SEGDES,MELVAL
  590.           MELVAL=MELPLI
  591.           SEGDES,MELVAL
  592.           SEGSUP,NLOC4
  593.         ENDDO
  594.         NSZACC=ILOC3(/1)
  595.         DO ISZACC=1,NSZACC
  596.           NLOC3=ILOC3(ISZACC)
  597.           SEGSUP,NLOC3
  598.         ENDDO
  599.         NLOC3=ILOC3I
  600.         NCOMP=MELVAC(/1)
  601.         DO ICOMP=1,NCOMP
  602.           MELVAL=MELVAC(ICOMP)
  603.           SEGDES,MELVAL
  604.         ENDDO
  605.         SEGSUP,NLOC3
  606.         NLOC3=ILOC3O
  607.         NCOMP=MELVAC(/1)
  608.         DO ICOMP=1,NCOMP
  609.           MELVAL=MELVAC(ICOMP)
  610.           SEGDES,MELVAL
  611.         ENDDO
  612.         SEGSUP,NLOC3
  613.         MMODEL=MODLAC
  614.         DO ISZACC=1,NSZACC
  615.           MINTE=MINTAC(ISZACC)
  616.           SEGDES,MINTE
  617.           IMODEL=KMODEL(ISZACC)
  618.           SEGDES,IMODEL
  619.         ENDDO
  620.         MELEME=MAILEF
  621.         SEGDES,MELEME
  622.       ENDDO
  623.       DO IZONEF=1,NZONEF
  624.         NLOC2=ILOC2(IZONEF)
  625.         MMODEL=MODLAC
  626.         SEGDES,MMODEL
  627.         SEGSUP,NLOC2
  628.       ENDDO
  629.       SEGSUP,NLOC1
  630. C
  631. C     BYE BYE
  632. C
  633.       RETURN
  634.       END
  635.  
  636.  
  637.  
  638.  
  639.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales