Télécharger la plaquette Cast3M


fr en

Télécharger nloca1.eso

Retour à la liste

Numérotation des lignes : 

nloca1

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

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