Télécharger la plaquette Cast3M


fr en

Télécharger conne1.eso

Retour à la liste

Numérotation des lignes : 

conne1

  1. C CONNE1    SOURCE    MB234859  25/09/08    21:15:18     12358          
  2.       SUBROUTINE CONNE1(IPMODL,XLONG,IXLONG,CONSTI,ICLE,JPT1,JPT2,JPT3,
  3.      >                  IPCHCO,IRET)
  4. C_______________________________________________________________________
  5. C
  6. C           CALCUL DES CONNECTIVITES APPELE PAR CONNEC
  7. C
  8. C    Entrees:
  9. C    ________
  10. C
  11. C           IPMODL Pointeur sur un objet MMODEL
  12. C           XLONG  Longeur caracteristique
  13. C           IXLONG Champ de longeur caracteristique
  14. C           CONSTI nom du constituant
  15. C           ICLE   mode de modification du maillage pour le calcul
  16. C                  (1=NORM, 3=POIN, 4=DROI, 5=PLAN, 2=TRAN)
  17. C           JPT1|
  18. C           JPT2|  pointeurs eventuels sur des objets de type point
  19. C           JPT3|
  20. C
  21. C
  22. C    Sorties:
  23. C    ________
  24. C
  25. C           IPCHCO Pointeur sur un MCHAML de Connectivite
  26. C           de composantes obligatoires ...
  27. C
  28. C                  'NLAR': Non local Longueur cARacteristique
  29. C                  'PMOD': Pointeur sur un MMODEL contenant
  30. C                          l'ensemble des IMODEL accessibles
  31. C                          pour la sous zone
  32. C                  'NPNI': Non local Pointeur Numero Imodel de nmod
  33. C                  'NPLI': Non local Pointeur LIstenti
  34. C
  35. C           ... et eventuellement
  36. C
  37. C                  'POT1': Point ou vecteur de construction de symetrie
  38. C                          (POIN, DROI, PLAN, TRAN)
  39. C                  'POT2': Point de construction de symetrie (DROI)
  40. C                  'DISP': Distance pour calcul de symetrie PLAN (PLAN)
  41. C
  42. C           IRET   1 ou 0 suivant succes ou pas
  43. C
  44. C    Appele par: CONNEC
  45. C    -----------
  46. C
  47. C    Appel a:
  48. C    --------
  49. C
  50. C    LOADPO : lecture d'un point (pointeur --> x(3))
  51. C    NORPLA : calcul de l'eq. canonique d'un plan passant par 3 pts
  52. C    ADJUPO : ajout d'un point dans la pile des points (x(3) --> pointeur)
  53. C    NORDRO : calcul du vect. dir. norme de la droite passant par 2 pts
  54. C    DISYPT : distance a un point
  55. C    DISYDR : distance a une droite
  56. C    DISYPL : distance a un plan
  57. C    TRTRVE : point translate
  58. C    TRSYPT : point symetrique par rapport a un point
  59. C    TRSYDR : point symetrique par rapport a une droite
  60. C    TRSYPL : point symetrique par rapport a un plan
  61. C    ELQUOI, DOXE, DTSHAM
  62. C
  63. C    AUTEUR P.PEGON 22/10/92 d'apres C. LA BORDERIE d'apres P.PEGON
  64. C_______________________________________________________________________
  65. C
  66.       IMPLICIT INTEGER(I-N)
  67.       IMPLICIT REAL*8(A-H,O-Z)
  68.  
  69. -INC PPARAM
  70. -INC CCOPTIO
  71. -INC CCASSIS
  72. -INC CCREEL
  73.  
  74. -INC SMELEME
  75. -INC SMCOORD
  76. -INC SMMODEL
  77. -INC SMCHAML
  78. -INC SMLENTI
  79.  
  80. -INC TMPTVAL
  81.  
  82.       PARAMETER(MASDIM=64)
  83.       common/CCONNE/iwrk3,ipmodl1,xmultl,icle1,ihgsel
  84.       common/CCONNE/jconl,ihg1,ihg2,ihg,nbthr,ixlong1
  85.       COMMON/CHSELE/imfopa,ishg,ihug,imcord,ihgt
  86.       common/CCONN1/d,pt1(3),pt2(3)
  87.       common/CCONN1/xmn(masdim),ymn(masdim),zmn(masdim)
  88.       common/CCONN1/xmx(masdim),ymx(masdim),zmx(masdim)
  89.       common/CCONN1/hmxt(masdim),xlg2m(masdim)
  90.       external crbary
  91.       external hselei
  92.       logical zthr
  93.       SEGMENT,WRK1
  94.         REAL*8 XE(3,nbno1)
  95. C coord des noeuds
  96.       ENDSEGMENT
  97.  
  98.       SEGMENT,WRK2
  99.         REAL*8 XEJ(3,nbno1)
  100.       ENDSEGMENT
  101.  
  102.       SEGMENT,WRK3
  103.          INTEGER IWRK1(NSOUS,nbthr), IWRK2(NSOUS,nbthr)
  104.      +   ,imptv(nsous)
  105. C iwrk1 pointe vers les wrk1 et iwrk2 pointe sur les wrk2
  106.       ENDSEGMENT
  107.  
  108.       pointeur IPMAIL.MELEME
  109.       pointeur MLNIMO.MLENTI
  110.       pointeur MLNUEL.MLENTI
  111.       pointeur MCORD2.MCOORD
  112.  
  113.       SEGMENT NOTYPE
  114.         CHARACTER*16 TYPE(NBTYPE)
  115.       ENDSEGMENT
  116.  
  117. C hg1 contient les coordonnees des barycentres de la zone de travail
  118. C hg2 contient les coordonnees des barycentres  de la deuxieme zone
  119.       SEGMENT HG1
  120.         REAL*8 HCOOR(3*nbpb)
  121.       ENDSEGMENT
  122.       pointeur hg2.hg1
  123. C HG contient les correspondances entre numérotation locale et numerotation castem
  124. C    ainsi que des donnees permettant d'ecrire le resultat
  125.       SEGMENT HG
  126.         INTEGER IELH(nbpb,2)
  127. C IELH(i,1)=numero de l'element dans la sous zone
  128. C IELH(i,2)=numero de la sous zone
  129. C Tableau qui contient le max d(noeuds, barycentre)
  130.         REAL*8 HMax(nbpb)
  131. C si ixlong different de zero contient le max de ixlong dans l'element
  132.         REAL*8 XLL(nbpb)
  133. C Tableau qui contient nombre d'ele en connex par sous zone
  134.         INTEGER INOA(nbpb,NSOUS+1)
  135.       ENDSEGMENT
  136. C hgt contient les tableaux utile pour le tri
  137.       SEGMENT HGT
  138. C       integer ka(nels),kb(nels)
  139. C Tableau contenant proj ortho sur la droite apres tri
  140.         REAL*8 Xp(nels)
  141. C Tableau auxiliaire  pour triflot
  142.         REAL*8 Xw(nels)
  143. C Tableau auxiliaire pour triflot
  144.         INTEGER Ke(nels)
  145. C Tableau donne la correspondance entre le tableau trie et la numerotation de la zone 2
  146.         INTEGER ICO(nels)
  147.       ENDSEGMENT
  148.  
  149.       SEGMENT mfopa
  150. C Premier element dans un segment de la droite
  151.         INTEGER ind(indt)
  152.       ENDSEGMENT
  153. C  lhug la liste des elements en relation - on s'y retrouve grace a inoa
  154.       SEGMENT iVECTI
  155.         INTEGER Lhug(JG)
  156.       ENDSEGMENT
  157.       pointeur ivect1.ivecti
  158.  
  159.       segment mlhug
  160.          integer ilhug(nbthr)
  161.          integer nhug(nbthr)
  162.       endsegment
  163. C VECTEUR corresp entre numero des elements conserves (cas symetrie) et numerotation locale
  164.       SEGMENT SHG
  165.         INTEGER NSYM(NELS)
  166.       ENDSEGMENT
  167.  
  168. C permet de ne pas recalculer le symetrique d'un noeud
  169.       SEGMENT NOETR
  170.         INTEGER NDEJVU(NBPTS)
  171.       ENDSEGMENT
  172. C permet de savoir s'il faut creer un segment resultat (1 oui 0 non)
  173.       SEGMENT CONL
  174.         INTEGER ICONL(NBPB)
  175.       ENDSEGMENT
  176.       segment kkzt
  177.         integer kzt(nbpb)
  178.       endsegment
  179.  
  180.       segment hgsele
  181.          real*8 xmult,ymult,zmult
  182.          real*8 hmaxt,xlong2,tmax,tmin,xlong2m
  183.          integer nels,nbpb,ipass
  184.          integer nbzt,indt,khug
  185.       endsegment
  186.  
  187.       CHARACTER*(NCONCH) CONM
  188.       PARAMETER (NINF=3)
  189.       INTEGER INFOS(NINF)
  190.  
  191.       CHARACTER*16 CONSTI
  192.       DIMENSION PT3(3)
  193.  
  194.       integer ittime(4)
  195.       data xmultl/1.5D0/
  196. c
  197. C      i232 = 2**32
  198.  
  199.       ixlong1 = ixlong
  200.       icle1 = icle
  201. C LECTURE DES POINTS
  202.       CALL LOADPO(JPT1,PT1)
  203.       CALL LOADPO(JPT2,PT2)
  204.       CALL LOADPO(JPT3,PT3)
  205.  
  206. C CALCUL DE LA NORMALE NORMEE ET DE LA DISTANCE POUR KE CAS DU PLAN
  207. C ET AJOUT DU POINT A LA PILE
  208.  
  209.       segini hgsele
  210.        ihgsel = hgsele
  211.        khug = 0
  212. C     call timespv(ittime,othrd)
  213. C     ide = ittime(1) + ittime(2)
  214.       IF (ICLE.EQ.5) then
  215.          CALL NORPLA(PT1,PT2,PT3,pt1,D)
  216.          CALL ADJUPO(PT1,JPT1)
  217.       ENDIF
  218. C CALCUL DU VECTEURE DIRECTEUR NORME DANS
  219. C DANS LE CAS DE LA DROITE ET AJOUT DU POINT A LA PILE
  220. C
  221.       IF (ICLE.EQ.4) THEN
  222.         CALL NORDRO(PT1,PT2,PT2)
  223.         CALL ADJUPO(PT2,JPT2)
  224.       ENDIF
  225. C
  226. C
  227.  
  228.       iret=1
  229. C
  230. C
  231. C____________________________________________________________________
  232. C
  233. C     PREPARATIONS DE LA LONGUEUR CARACTERISTIQUE
  234. C____________________________________________________________________
  235. C
  236.       IF(IXLONG.NE.0)THEN
  237. C
  238.         INFOS(1)=0
  239.         INFOS(2)=0
  240.         INFOS(3)=NIFOUR
  241. C
  242.         NBROBL=1
  243.         NBRFAC=0
  244.         SEGINI NOMID
  245.         NOMLAR=NOMID
  246.         LESOBL(1)='LCAR'
  247.         NBTYPE=1
  248.         SEGINI NOTYPE
  249.         MOTYPE=NOTYPE
  250.         TYPE(1)='REAL*8'
  251.       ELSE
  252.         XLONG2 = XMULTl * XLONG
  253.       ENDIF
  254. C
  255. C     ACTIVATION DU MODELE
  256. C
  257.       MMODEL=IPMODL
  258.       SEGACT,MMODEL
  259.       NSOUS=KMODEL(/1)
  260. C
  261. C     ACTIVATION DES ZONES ELEMENTAIRES DU MAILLAGE
  262. C
  263.        nbthr = nbthrs
  264.        segini wrk3
  265.        nbelz=0
  266.        DO ISOUS=1,NSOUS
  267.           IMODEL=KMODEL(ISOUS)
  268.           SEGACT,IMODEL
  269.           IPMAIL=IMAMOD
  270.           SEGACT,IPMAIL
  271.           nbno1=IPMAIL.num(/1)
  272.           nbelz=nbelz + IPMAIL.num(/2)
  273.           do i = 1, nbthrs
  274.              segini wrk1
  275.              segini wrk2
  276.              wrk3.iwrk1(isous,i)=wrk1
  277.              wrk3.iwrk2(isous,i)=wrk2
  278.           enddo
  279.           if (ixlong.ne.0) then
  280.              conm  = conmod
  281.              minte = IMODEL.INFMOD(7)
  282.              call komcha(ixlong,ipmail,conm,nomlar,motype,1,infos,3
  283.      +                  ,ivalar)
  284.              if (ierr.ne.0) then
  285.                 nomid  = nomlar
  286.                 notype = motype
  287.                 segsup ,nomid,notype
  288.                 goto 9999
  289.              endif
  290.              mptval = ivalar
  291.              melval = ival(1)
  292.              segact melval
  293.              imptv(isous) = melval
  294.              call dtmval(ivalar,2)
  295.           endif
  296.        ENDDO
  297.  
  298.        nbpb=nbelz
  299.  
  300.        segini kkzt
  301.        SEGINI HG
  302.        ihg = hg
  303.        segini hg1
  304.        ihg1   = hg1
  305.        ihg2   = hg1
  306.        xmin=xgrand
  307.        ymin=xgrand
  308.        zmin=xgrand
  309.        xmax=-xgrand
  310.        ymax=-xgrand
  311.        zmax=-xgrand
  312.        hmaxt = 0d0
  313.        xlong2m = 0d0
  314. C
  315.        mcord2=mcoord
  316.        imcord = mcord2
  317.        hg2=hg1
  318.        SEGINI CONL
  319.        do ib1=1,nbpb
  320.           iconl(ib1)=1
  321.        ENDDO
  322. C on regarde si on parallelise
  323.        if (LODESL.or.nbthrs.eq.1.or.nbpb.lt.nbthrs) then
  324.           zthr = .FALSE.
  325.           nbthr = 1
  326.        else
  327.           zthr = .TRUE.
  328.           nbthr = nbthrs
  329. C         nbthr = 20
  330.        endif
  331. C        zthr = .FALSE.
  332. C        nbthr = 1
  333. C On fait une boucle pour créer une numerotation
  334. C
  335.        ib1 = 0
  336.        NELS = NBPB
  337.        ishg = 0
  338.        if (icle.ne.1) then
  339.          SEGINI SHG,hg2
  340.          ishg   = shg
  341.          ihg2   = hg2
  342.        endif
  343.        do isous = 1, nsous
  344.           IMODEL   = KMODEL(ISOUS)
  345.           IPMAIL   = IMAMOD
  346.           nbel1    = IPMAIL.num(/2)
  347.           nbno1    = IPMAIL.num(/1)
  348.           do iel1 = 1, nbel1
  349.              IB1         = IB1 + 1
  350.              IELH(IB1,1) = iel1
  351.              IELH(IB1,2) = ISOUS
  352.           enddo
  353.        enddo
  354.        jconl  = conl
  355.        inoetr = noetr
  356.        iwrk3  = wrk3
  357. C       ihg    = hg
  358.        ipmodl1 = ipmodl
  359.  
  360. C On fait une boucle sur tous les éléments pour créer les centres de gravité et une numérotation
  361.        if (zthr) then
  362.           call threadii
  363.           do ith = 2, nbthr
  364.              call threadid(ith,crbary)
  365.           enddo
  366.           call crbary(1)
  367.           do ith = 2, nbthr
  368.              call threadif(ith)
  369.           enddo
  370.           call threadis
  371.        else
  372.           call crbar1(iwrk3,ipmodl1,1,nbpb,xmultl,icle,d,pt1,pt2
  373.      +      ,jconl,ihg1,ihg2,xmn,ymn,zmn,xmx,ymx,zmx
  374.      +      ,hmxt,ihg,1,ixlong,xlong2,xlg2m)
  375.        endif
  376. c
  377.        do i = 1, nbthr
  378.           xmax = max (xmax,xmx(i))
  379.           ymax = max (ymax,ymx(i))
  380.           zmax = max (zmax,zmx(i))
  381.           xmin = min (xmin,xmn(i))
  382.           ymin = min (ymin,ymn(i))
  383.           zmin = min (zmin,zmn(i))
  384.           hmaxt = max (hmaxt,hmxt(i))
  385.           xlong2m = max(xlong2m,xlg2m(i))
  386.        enddo
  387.  
  388. C
  389. C on fait une boucle pour tasser les tableaux dans le cas icle = 3,4,5
  390.        if (icle.eq.2.or.icle.eq.3.or.icle.eq.4.or.icle.eq.5) then
  391.        ik1 = 0
  392.        ib  = 0
  393.        do ib = 1, nbpb
  394.           if (iconl(ib).eq.1) then
  395.              ik1 = ik1 + 1
  396.              nsym(ik1) = ib
  397.              hg2.HCOOR((IK1-1)*3+1) = hg2.HCOOR((Ib-1)*3+1)
  398.              hg2.HCOOR((IK1-1)*3+2) = hg2.HCOOR((Ib-1)*3+2)
  399.              hg2.HCOOR((IK1-1)*3+3) = hg2.HCOOR((Ib-1)*3+3)
  400.                  HCOOR((IK1-1)*3+1) =     HCOOR((Ib-1)*3+1)
  401.                  HCOOR((IK1-1)*3+2) =     HCOOR((Ib-1)*3+2)
  402.                  HCOOR((IK1-1)*3+3) =     HCOOR((Ib-1)*3+3)
  403.  
  404.           endif
  405.        enddo
  406.        endif
  407.        if (icle.ne.1) then
  408.           NELS=IK1
  409.           SEGADJ SHG,hg2,hg1
  410.        endif
  411. C CALCUL DES NOEUDS DES SYM QU'ON STOCKE DANS HCOR2
  412.         if (icle.ne.1) then
  413.            SEGINI MCORD2
  414.            imcord = mcord2
  415.            SEGINI NOETR
  416.            DO IB = 1, NELS
  417.               ib1 = ib
  418.               if (icle.eq.5) IB1 = NSYM(IB)
  419.               if (icle.eq.4) IB1 = NSYM(IB)
  420.               if (icle.eq.3) IB1 = NSYM(IB)
  421.               IEL = IELH(IB1,1)
  422.               IZO = IELH(IB1,2)
  423.               imodel = kmodel(izo)
  424.               ipmail = imamod
  425.               nn2    = ipmail.num(/1)
  426.               do ij = 1, nn2
  427.                  ino1=ipmail.num(ij,iel)
  428.                  IF (NDEJVU(INO1).EQ.0) THEN
  429.                     NDEJVU(INO1) = 1
  430.                     B = D
  431.                     if (icle.eq.5) then
  432.                        DO J = 1, idim
  433.                           B = B + XCOOR((ino1-1)*(idim+1)+J)*PT1(J)
  434.                       ENDDO
  435.                       B = B * 2
  436.                       DO J = 1, idim
  437.                          MCORD2.XCOOR((ino1-1)*(idim+1)+J) =
  438.      +                        XCOOR((ino1-1)*(idim+1)+J) - B * PT1(J)
  439.                       enddo
  440. C
  441.                     elseif(icle.eq.4) then
  442.                       b=0D0
  443.                       DO J = 1, idim
  444.                          B = B + PT2(J)
  445.      +                     * (xcoor((ino1-1)*(idim+1)+J)-PT1(J))
  446.                       ENDDO
  447.  
  448.                       DO J = 1, idim
  449.                          tata = +2*(PT1(J)-xcoor((ino1-1)*
  450.      +                    (idim+1)+J)+B*PT2(J))
  451.                          titi=(xcoor((ino1-1)*(idim+1)+J))+tata
  452.                          MCORD2.XCOOR((ino1-1)*(idim+1)+J)=titi
  453.                       enddo
  454.  
  455.                     elseif(icle.eq.3) then
  456.                       DO J=1,idim
  457.                           MCORD2.XCOOR((ino1-1)*(idim+1)+J)=
  458.      +                      xcoor((ino1-1)*(idim+1)+J)+2*(PT1(J)
  459.      +                     -xcoor((ino1-1)*(idim+1)+J))
  460.                       ENDDO
  461.                    elseif(icle.eq.2) then
  462.                       DO J=1,idim
  463.                           MCORD2.XCOOR((ino1-1)*(idim+1)+J)=
  464.      +                      xcoor((ino1-1)*(idim+1)+J)+PT1(J)
  465.                       ENDDO
  466.                    endif
  467.                  ENDIF
  468.               enddo
  469.            ENDDO
  470.         endif
  471. C
  472. C debut du tri des projs
  473. C
  474. C
  475. C
  476. C
  477.        segini hgt
  478.        ihgt = hgt
  479.        xmult = 3.1415926 * (xmax-xmin)
  480.        ymult = 2.7182818 * (ymax-ymin)
  481.        zmult = 1.        * (zmax-zmin)
  482.        tmult = sqrt(xmult**2+ymult**2+zmult**2)
  483.        if (tmult.le.xpetit) then
  484.           xmult = 3.1415926
  485.           ymult = 2.7182818
  486.           zmult = 1.
  487.           tmult = sqrt(xmult**2+ymult**2+zmult**2)
  488.        endif
  489.        xmult = xmult / tmult
  490.        ymult = ymult / tmult
  491.        zmult = zmult / tmult
  492.        tmin =   xgrand
  493.        tmax =  -xgrand
  494.        DO ib1 = 1, nels
  495.           xproj = hg2.HCOOR((IB1-1)*3+1) * xmult
  496.      +          + HG2.HCOOR((IB1-1)*3+2) * ymult
  497.      +          + HG2.HCOOR((IB1-1)*3+3) * zmult
  498.  
  499.           Xp(ib1)  = xproj
  500.           tmin     = min(xproj,tmin)
  501.           tmax     = max(xproj,tmax)
  502.           ico(ib1) = ib1
  503.        ENDDO
  504.        if (abs(tmin-tmax).le.xpetit) then
  505.           tmin = tmin - 0.5
  506.           tmax = tmax + 0.5
  507.        endif
  508.        if (ixlong.ne.0)  xlong2 = xlong2m
  509. *  quelques contorsions pour eviter un integer overflow
  510.        xbzt = (tmax-tmin) / xlong2
  511.        xbzt = max(xbzt,1.d0)
  512.        xels=nels
  513.        xbzt = min(xels,xbzt)
  514.        nbzt=xbzt
  515.  
  516.        CALL TRIFLO(Xp,Xw,ico,Ke,nels)
  517.  
  518.        if (icle.eq.3) then
  519.  
  520.        endif
  521.        indt=nbzt+1
  522.        segini mfopa
  523.        imfopa = mfopa
  524.        DO i = nels, 1, -1
  525.          id = nbzt*(Xp(i)-tmin) / (tmax-tmin) + 1
  526.          ind(id)=i
  527.        ENDDO
  528.        DO i = 1, nbzt
  529.           if (ind(i+1).eq.0) ind(i+1)=ind(i)
  530.           if(ind(i+1).lt.ind(i)) call erreur(5)
  531.        ENDDO
  532.        if (zthr) then
  533.           ilon1 = nels / nbthr + 1
  534.        else
  535.           ilon1 = nels
  536.        endif
  537. C         jg = I232
  538. C         jg1 = jg / nbthr
  539. C         jg = jg1
  540. C double passage pour estimation taille de ivecti
  541.        do ipas = 1, 2
  542.           ipass = ipas
  543.        if (ipas.eq.1) then
  544.        segini mlhug
  545.        ihug = mlhug
  546.        endif
  547. C       JG= ilon1 * nels
  548. C       jg = min(jg,jg1)
  549. C       khug = jg
  550.        if (ipas.eq.2) then
  551.        do i = 1, nbthr
  552.           jg = nhug(i)
  553.           segini ivecti
  554.           ilhug(i) = ivecti
  555.           nhug(i) = 0
  556.        enddo
  557.        endif
  558.  
  559.        if (zthr) then
  560.           call threadii
  561.           do ith = 2, nbthr
  562.              call threadid(ith,hselei)
  563.           enddo
  564.           call hselei(1)
  565.           do ith = 2, nbthr
  566.              call threadif(ith)
  567.           enddo
  568.           call threadis
  569.        else
  570.           call hsele1(1,1,nels,imfopa,ihg1,ihg2,iwrk3,ishg,ihug
  571.      +          ,ihgsel,ihg,ipmodl,icle,imcord,ihgt,ixlong)
  572.        endif
  573. C fin de la boucle ipass
  574.        enddo
  575. C
  576. C ecriture du chamelem resultat
  577. C
  578.        N1=NSOUS
  579.        L1=22
  580.        N3=6
  581.        SEGINI,MCHELM
  582.        IPCHCO=MCHELM
  583.        TITCHE='CONNECTIVITE NON LOCAL'
  584.        IFOCHE=IFOUR
  585.        DO ISOUS = 1, NSOUS
  586.           IMODEL = KMODEL(ISOUS)
  587.           IPMAIL = IMAMOD
  588.           CONCHE(ISOUS) = CONSTI
  589.           CONM = CONMOD
  590.           NBEL = IPMAIL.NUM(/2)
  591.           NBNN = IPMAIL.NUM(/1)
  592. C INFORMATIONS SUR L'ELEMENT FINI
  593.           minte=infmod(7)
  594. C
  595. C COMPLEMENT DU CHAMELEM
  596. C
  597.          IMACHE(ISOUS)=IPMAIL
  598.          INFCHE(ISOUS,1)=0
  599.          INFCHE(ISOUS,2)=0
  600.          INFCHE(ISOUS,3)=NIFOUR
  601.          INFCHE(ISOUS,4)=MINTE
  602.          INFCHE(ISOUS,5)=0
  603.          INFCHE(ISOUS,6)=5
  604.  
  605. C____________________________________________________________________
  606. C
  607.  
  608.  
  609.         IF (ICLE.EQ.1) n2=4
  610.         IF (ICLE.EQ.2.OR.ICLE.EQ.3) N2=5
  611.         IF(ICLE.EQ.4.OR.ICLE.EQ.5)  N2=6
  612. C TAILLE DES MELVALS A ALLOUER ET ALLOCATION
  613. C CREATION DU MCHAML DE LA SS ZONE
  614. C CAS SYMETRIE A PAS OUBLIER
  615.         SEGINI MCHAML
  616.         ICHAML(ISOUS) = MCHAML
  617. C CREATION DU PREMIER MELVAL
  618. C        'NLAR': DONNE LA LONGUEUR CARACTERISTIQUE
  619. C CE MELVAL EST CONSTANT DANS CHAQUE SS ZONE
  620.          NOMCHE(1) = 'NLAR'
  621.          TYPCHE(1) = 'REAL*8'
  622.          N2PTEL = 0
  623.          N2EL   = 0
  624. C CAS CHAMP CARA
  625.          if (ixlong.ne.0) then
  626.             melval = imptv(isous)
  627.             segini,melva1=melval
  628.             ielval(1) = melva1
  629.          else
  630.             N1PTEL = 1
  631.             N1EL   = 1
  632.             SEGINI, MELVAL
  633.             IELVAL(1)   = MELVAL
  634.             VELCHE(1,1) = XLONG
  635.          endif
  636. C CREATION DU DEUXIEME MELVAL
  637. C 'PMOD': PONTE SUR UN MODELE INDIQUANT LES ZONES GEOMETRIQUES
  638. C CE MELVAL EST CONSTANT
  639.          N1PTEL = 0
  640.          N1EL   = 0
  641.          N2PTEL = 1
  642.          N2EL   = 1
  643.          NOMCHE(2) = 'PMOD'
  644.          TYPCHE(2) = 'POINTEURMMODEL '
  645.          SEGINI MELVAL
  646.          IELVAL(2)   = MELVAL
  647.          IELCHE(1,1) = MMODEL
  648.  
  649. C 'NPNI : POINTE SUR UN LISTENTI CONTENANT LE NUMERO DU IMODEL
  650. C ACCESSIBLE POUR CHAQUE ELEMENT
  651. C 'NPLI': POINTE SUR UN LISTENTI CONTENANT UNE LINKED
  652. C LISTE DES ELEMENTS ACCESSIBLES SUR CHAQUE ZONE
  653.  
  654.           N1EL   = 0
  655.           N1PTEL = 0
  656.           N2PTEL = 1
  657.           N2EL   = NBEL
  658.           NOMCHE(3) = 'NPNI'
  659.           TYPCHE(3) = 'POINTEURLISTENTI'
  660.           SEGINI, MELVAL
  661.           IELVAL(3) = MELVAL
  662.           NOMCHE(4) = 'NPLI'
  663.           TYPCHE(4) = 'POINTEURLISTENTI'
  664.           SEGINI, MELVAL
  665.           IELVAL(4) = MELVAL
  666. C
  667. C
  668. C     'POT1' : POINTE SUR UN OBJET DE TYPE POINT
  669. C
  670. C              CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  671. C
  672.         IF(ICLE.NE.1)THEN
  673.           N1PTEL=0
  674.           N1EL=0
  675.           N2PTEL=1
  676.           N2EL=1
  677.           NOMCHE(5)='POT1'
  678.           TYPCHE(5)='POINTEURPOINT   '
  679.           SEGINI MELVAL
  680.           IELVAL(5)=MELVAL
  681.           IELCHE(1,1)=JPT1
  682.         ENDIF
  683. C
  684. C
  685. C     'POT2' : POINTE SUR UN OBJET DE TYPE POINT
  686. C
  687. C              CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  688. C
  689.         IF(ICLE.EQ.4)THEN
  690.           N1PTEL=0
  691.           N1EL=0
  692.           N2PTEL=1
  693.           N2EL=1
  694.           NOMCHE(6)='POT2'
  695.           TYPCHE(6)='POINTEURPOINT   '
  696.           SEGINI MELVAL
  697.           IELVAL(6)=MELVAL
  698.           IELCHE(1,1)=JPT2
  699.         ENDIF
  700. C
  701. C     'DISP' : DONNE LA DISTANCE AU PLAN
  702. C
  703. C              CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  704. C
  705.         IF(ICLE.EQ.5)THEN
  706.           N2PTEL=0
  707.           N2EL=0
  708.           N1PTEL=1
  709.           N1EL=1
  710.           NOMCHE(6)='DISP'
  711.           TYPCHE(6)='REAL*8'
  712.           SEGINI,MELVAL
  713.           IELVAL(6)=MELVAL
  714.           VELCHE(1,1)=D
  715.         ENDIF
  716. C
  717.        ENDDO
  718.  
  719. C debut de la boucle pour ranger les numeros d element
  720.  
  721.        DO IB1= 1, nbpb
  722.          kzt(ib1) = 0
  723.          knb=0
  724.          DO ISOUS=1, NSOUS
  725.             IF(inoa(IB1,ISOUS).NE.0) then
  726.               kzt(ib1)=kzt(ib1)+1
  727.               knb=knb+inoa(IB1,ISOUS)+1
  728.             ENDIF
  729.  
  730.          ENDDO
  731.          IZO=IELH(IB1,2)
  732.          IEL=IELH(IB1,1)
  733.          MCHAML=ICHAML(IZO)
  734.          if(iconl(ib1).eq.0.or.kzt(ib1).eq.0) then
  735.            melval=ielval(3)
  736.            ielche(1,iel)=0
  737.            melval=ielval(4)
  738.            ielche(1,IEL)=0
  739.          else
  740.            melval=ielval(3)
  741.              jg=kzt(ib1)
  742.              SEGINI MLENTI
  743.              Ielche(1,Iel)=MLENTI
  744.              melval=ielval(4)
  745.              JG=KNB
  746.              SEGINI MLENTI
  747.              ielche(1,IEL)=MLENTI
  748.          endif
  749.        ENDDO
  750. C REMPLISSAGE DES LISTENTI
  751.  
  752.        do ith = 1, nbthr
  753.           ivecti = ilhug(ith)
  754.           nbthr1 = nbthr
  755.           if (ith.gt.nbthr1) goto 999
  756.           ires = mod(nels,nbthr1)
  757.           if (ires.eq.0) then
  758.              ilon1 = nels / nbthr1
  759.              ideb = (ith - 1) * ilon1 + 1
  760.           else
  761.              if (ith.le.ires) then
  762.                 ilon1 = nels / nbthr1 + 1
  763.                 ideb = (ith - 1) * ilon1 + 1
  764.              else
  765.                 ilon1 = nels / nbthr1
  766.                 ideb = (ires * (ilon1 + 1)) + (ith - ires - 1)*ilon1+1
  767.              endif
  768.           endif
  769.           ifin = ideb + ilon1 - 1
  770.           if (ifin.ge.ideb) then
  771.           ICP=0
  772.           DO iIB1=ideb, ifin
  773.              ib1 = iib1
  774.              if (icle.eq.3.or.icle.eq.4.or.icle.eq.5) ib1=nsym(iib1)
  775.              if (iconl(IB1).eq.1.and.kzt(ib1).ne.0) then
  776.                 KZTl=0
  777.                 IEL=IELH(IB1,1)
  778.                 IZO=IELH(IB1,2)
  779.                 MCHAML=ICHAML(IZO)
  780.                 MELVAL=IELVAL(3)
  781.                 MLENTI=IELCHE(1,IEL)
  782.                 MELVAL=IELVAL(4)
  783.                 MLNIMO=IELCHE(1,IEL)
  784.                 N1=MLNIMO.LECT(/1)
  785.                 NCP1=0
  786.                 NTOT=0
  787.                 DO ISOUS=1, NSOUS
  788.                 IF (INOA(IB1,ISOUS).NE.0) THEN
  789.                    NTOT=NTOT+INOA(IB1,ISOUS)
  790.                    NCP=INOA(IB1,ISOUS)
  791.  
  792.                    NCP1=NCP1+1
  793.                    MLNIMO.LECT(NCP1)=INOA(IB1,ISOUS)
  794.  
  795.                    KZTl=KZTl+1
  796.                    MLENTI.LECT(KZTl)=ISOUS
  797.                    DO I1=1, INOA(IB1,NSOUS+1)
  798.                       IB2=LHUG(ICP+I1)
  799.                       IZO2=IELH(IB2,2)
  800.                       IF (IZO2.EQ.ISOUS) THEN
  801.                          IEL2=IELH(IB2,1)
  802.                          NCP1=NCP1+1
  803.                          MLNIMO.LECT(NCP1)=IEL2
  804.                       ENDIF
  805.                    ENDDO
  806.                 ENDIF
  807.  
  808.           ENDDO
  809.          ICP=ICP+NTOT
  810.          endif
  811. C fin de la boucle sur les éléments
  812.        ENDDO
  813.        endif
  814.  999  continue
  815. C fin de la boucle sur nbthr
  816.           segsup ivecti
  817.        enddo
  818.  
  819.  
  820.        segsup mlhug
  821.       segsup hg1,hgt,hg,conl
  822.       do ii = 1, nsous
  823.          do i = 1, nbthr
  824.             wrk1 =iwrk1(ii,i)
  825.             wrk2 =iwrk2(ii,i)
  826.             segsup wrk1,wrk2
  827.          enddo
  828.       enddo
  829.       segsup wrk3
  830.       segsup mfopa
  831.       segsup ivecti
  832.       segsup kkzt
  833.       if (icle.ne.1) then
  834.          segsup hg2,shg,noetr,mcord2
  835.       endif
  836. c
  837. C desactivation de l'objet resultat pour qu'il ne soit plus actif en ecriture
  838. C ce qui n'a pas ete cree dans la routine est laisse ouvert
  839. c
  840.  
  841.       mchelm = ipchco
  842.       do isous = 1, nsous
  843.          mchaml = ichaml(isous)
  844.          melval = ielval(1)
  845.          segdes melval
  846.          melval = ielval(2)
  847.          segdes melval
  848.          if (icle.ne.1) then
  849.             melval = ielval(5)
  850.             segdes melval
  851.          endif
  852.          if (icle.eq.4.or.icle.eq.5) then
  853.             melval = ielval(6)
  854.             segdes melval
  855.          endif
  856.          melval = ielval(3)
  857.          do jj = 1, ielche(/2)
  858.             if (ielche(1,jj).ne.0) then
  859.                mlenti = ielche(1,jj)
  860.                segdes mlenti
  861.             endif
  862.          enddo
  863.          segdes melval
  864.          melval = ielval(4)
  865.          do jj = 1, ielche(/2)
  866.             if (ielche(1,jj).ne.0) then
  867.                mlenti = ielche(1,jj)
  868.                segdes mlenti
  869.             endif
  870.          enddo
  871.          segdes melval
  872.          segdes mchaml
  873.       enddo
  874.       segdes mchelm
  875.  
  876.        if (zthr) then
  877.           call threadis
  878.        endif
  879.       return
  880. C____________________________________________________________________
  881. C
  882. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  883. C____________________________________________________________________
  884. C
  885.  9999 CONTINUE
  886.       IF(ISOUS.GT.1)THEN
  887.           DO  IE1=1,ISOUS
  888.             CALL DTSHAM(ICHAML(IE1))
  889.           ENDDO
  890.       ENDIF
  891.       SEGSUP,MCHELM
  892.       IPCHCO=0
  893.       IRET=0
  894. C
  895.       DO IE1=1,NSOUS
  896.         IMODEL=KMODEL(IE1)
  897.         IPMAIL=IMAMOD
  898.         SEGDES,IPMAIL,IMODEL
  899.       ENDDO
  900.       SEGDES,MMODEL
  901.  
  902.       RETURN
  903.       END
  904.  
  905.  
  906.  
  907.  

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