Télécharger la plaquette Cast3M


fr en

Télécharger hholim.eso

Retour à la liste

Numérotation des lignes : 

hholim

  1. C HHOLIM    SOURCE    OF166741  24/05/06    21:15:11     11082          
  2. C HHOLIM    SOURCE    FANDEUR                                           
  3. C
  4.       SUBROUTINE HHOLIM (chopt,IPGEO,lentHHO,iret)
  5.  
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12.  
  13. -INC CCHHOPA
  14. -INC CCHHOPR
  15.  
  16. -INC SMELEME
  17. -INC SMLENTI
  18.  
  19.       SEGMENT ipos(nbpt)
  20.       SEGMENT inds(mm)
  21.  
  22.       CHARACTER*(*) chopt
  23.  
  24.       iret = 0
  25.  
  26. c*      IF (IDIM.EQ.3) THEN
  27. c*        iret = 21
  28. c*        RETURN
  29. c*      END IF
  30.       IF ((chopt(1:4).NE.'CELL') .AND.
  31.      &    (chopt(1:4).NE.'FAEL') .AND.
  32.      &    (chopt(1:4).NE.'FACE')) THEN
  33.         write(ioimp,*) 'HHOLIM: incorrect keyword ',chopt(1:4)
  34.         iret = 5
  35.         RETURN
  36.       END IF
  37.  
  38. C= Les elements geometriques (cellules/faces) autorises :
  39.       IF (IDIM.EQ.3) THEN
  40.         indc = IC3MAX+1
  41.         lonc = NC3MAX
  42.         indf = IF3MAX+1
  43.         lonf = NF3MAX
  44.       ELSE IF (IDIM.EQ.2) THEN
  45.         indc = IC2MAX+1
  46.         lonc = NC2MAX
  47.         indf = IF2MAX+1
  48.         lonf = NF2MAX
  49. *      ELSE IF (IDIM.EQ.1) THEN
  50.       ELSE
  51.         indc = IC1MAX+1
  52.         lonc = NC1MAX
  53.         indf = IF1MAX+1
  54.         lonf = NF1MAX
  55.       END IF
  56.  
  57.       meleme = IPGEO
  58. C*      SEGACT,meleme <- Segment actif en Entree
  59.       nbsou = meleme.lisous(/1)
  60.       IF (nbsou.NE.0) THEN
  61.         write(ioimp,*) 'HHOLIM: IPGEO not simple'
  62.         iret = 21
  63.         RETURN
  64.       END IF
  65.  
  66.       IF (chopt(1:4).EQ.'FACE') THEN
  67.         ity = meleme.itypel
  68. c*face3Dpoly : inconnu a ce jour       if (ity.eq.  ) ity = formule a ecrire si necessaire
  69.         ityf = 0
  70.         CALL PLACE2(LIFHHO(indf),lonf,ityf,ity)
  71.         IF (ityf.EQ.0) THEN
  72.           write(ioimp,*) 'HHOLIM: IPFAC not implemented'
  73.           iret = 5
  74.           RETURN
  75.         END IF
  76. c*        ipt1 = MSQHHO
  77.         indli1 = meleme.num(/1)
  78.         ipt1 = MAFHHO(indli1)
  79. c-dbg      write(ioimp,*) chopt(1:4),'-',itypel,ityf,indli1,ipt1,MSQHHO
  80.       END IF
  81.  
  82.       IF (chopt(1:4).EQ.'CELL') THEN
  83.         ity = meleme.itypel
  84.         if (ity.eq.32) ity = ity * 100 + meleme.num(/1)
  85. c*poly3D : inconnu a ce jour       if (ity.eq.  ) ity = formule a ecrire si necessaire
  86.         ityc = 0
  87.         CALL PLACE2(LICHHO(indc),lonc,ityc,ity)
  88.         IF (ityc.EQ.0) THEN
  89.           write(ioimp,*) 'HHOLIM: IPCEL not implemented'
  90.           iret = 5
  91.           RETURN
  92.         END IF
  93. c*        ipt1 = MCEHHO
  94.         indli1 = ityc
  95.         ipt1 = MACHHO(indli1)
  96.         segact,ipt1
  97. c-dbg      write(ioimp,*) chopt(1:4),'-',itypel,ity,indli1,ipt1,MCEHHO
  98.       END IF
  99.  
  100.       IF (chopt(1:4).EQ.'FAEL') THEN
  101.         if (idim.eq.2) ity = 2
  102. c* on suppose que les faces sont d'un seul type pour l'instant !
  103. c* A FAIRE EN 3D en plus il y a des types differents !
  104.         ityf = 0
  105.         CALL PLACE2(LIFHHO(indf),lonf,ityf,ity)
  106.         IF (ityf.EQ.0) THEN
  107.           write(ioimp,*) 'HHOLIM: IPFAE not implemented'
  108.           iret = 5
  109.           RETURN
  110.         END IF
  111. c*        ipt1 = MSQHHO
  112.         indli1 = ity
  113.         ipt1 = MAFHHO(indli1)
  114.         segact,ipt1
  115. c-dbg      write(ioimp,*) chopt(1:4),'-',meleme.itypel,ityf,ipt1,MSQHHO
  116.       END IF
  117.  
  118.       nbno1 = ipt1.num(/1)
  119.       nbel1 = ipt1.num(/2)
  120.       ityp1 = ipt1.itypel
  121. c-dbg      write(ioimp,*) chopt(1:4),'IPT1=',ityp1,nbno1,nbel1,ipt1
  122.  
  123. C Le maillage ipt1 n'est pas simple :
  124.       if (nbno1.eq.0) then
  125.         write(ioimp,*) 'HHOLIM: TEST (1) incorrect'
  126.         iret = 5
  127.         return
  128.       end if
  129.  
  130.       mlenti = lentHHO
  131. C*      SEGACT,mlenti <- Segment actif en Entree
  132.  
  133. C Segments IPOS/INDS : 
  134.       ipos = mlenti.lect(6)
  135.       inds = mlenti.lect(7)
  136. c*      SEGACT,ipos*MOD
  137. c*      SEGACT,inds*MOD
  138.  
  139.       CALL HHOLI2('REMP_TOUS',ipt1,ipos,inds,iret)
  140.       IF (iret.NE.0) THEN
  141.         write(ioimp,*) 'HHOLIM-HHOLI2: inconsistent ipos/inds'
  142.         RETURN
  143.       END IF
  144.  
  145. C* Dresse la liste des faces des elements
  146.       IF (chopt(1:4).EQ.'FAEL') THEN
  147.       END IF
  148.  
  149.       meleme = IPGEO
  150. C*      SEGACT,meleme <- Segment actif en Entree
  151.       ipt2 = meleme
  152.       nbso2 = ipt2.lisous(/1)
  153.       nbno2 = ipt2.num(/1)
  154.       nbel2 = ipt2.num(/2)
  155.       ityp2 = ipt2.itypel
  156.  
  157. C Le maillage ipt2 n'est pas simple :
  158.       if (nbno2.eq.0) then
  159.         write(ioimp,*) 'HHOLIM: TEST (2) incorrect'
  160.         iret = 5
  161.         return
  162.       end if
  163.  
  164. c-dbg      write(ioimp,*) 'HHOLIM: ',chopt(1:4),' ',nbso2,ipt2,nbno2,nbel2
  165.       jg = 0
  166.       nbsou = MAX(1,nbso2)
  167.       DO i = 1, nbsou
  168.         IF (nbso2.NE.0) ipt2 = meleme.lisous(/1)
  169.         jg2 = 2 * ipt2.num(/2)
  170. c*        IF (chopt(1:4).EQ.'CELL') THEN
  171. c*        END IF
  172. c*        IF (chopt(1:4).EQ.'FACE') THEN
  173. c*        END IF
  174.         IF (chopt(1:4).EQ.'FAEL') THEN
  175. C= EN 2D : nb_faces = nbno2 en 3D a recuperer car un element peut avoir plusieurs types de faces
  176.           jg2 = jg2 * ipt2.num(/1)
  177.         END IF
  178.         jg = jg + jg2
  179.       END DO
  180. c-dbg      write(ioimp,*) 'HHOLIM: ',chopt(1:4),' NBJG',jg/2
  181.       SEGINI,mlent1
  182.  
  183.       IF (chopt(1:4).EQ.'FACE') THEN
  184. C Les maillages ne sont pas du meme type :
  185.         if ((ityp1.ne.ityp2) .or. (nbno1.ne.nbno2)) then
  186.           write(ioimp,*) 'HHOLIM : TEST (2) incorrect'
  187.           iret = 5
  188.           return
  189.         end if
  190.       END IF
  191.  
  192.       nbel2 = ipt2.num(/2)
  193.       IF (chopt(1:4).EQ.'FAEL') THEN
  194.         nbel2 = nbel2 * nbno2
  195. C= On doit avoir 2 en 2D, 3 ou 4 en 3D !
  196.       END IF
  197.  
  198. c-dbg      write(ioimp,*)
  199.       n_z = 0
  200.       DO jg2 = 1, nbel2
  201.         IF (chopt(1:4).EQ.'CELL') THEN
  202.           iel2 = jg2
  203.           ia = ipt2.num(1,iel2)
  204.           ib = ipt2.num(2,iel2)
  205. c-dbg      write(ioimp,*) 'CELL',iel2,ia,ib
  206.         END IF
  207.         IF (chopt(1:4).EQ.'FACE') THEN
  208.           iel2 = jg2
  209.           ia = ipt2.num(1,iel2)
  210.           ib = ipt2.num(2,iel2)
  211. c-dbg      write(ioimp,*) 'Element',iel2,chopt(1:4),ia,ib
  212.         END IF
  213.         IF (chopt(1:4).EQ.'FAEL') THEN
  214.           i_z = (jg2-1) / nbno2
  215.           iel2 = i_z + 1
  216.           in21 = jg2 - (i_z * nbno2)
  217.           in22 = MOD(in21,nbno2) + 1
  218.           ia = ipt2.num(in21,iel2)
  219.           ib = ipt2.num(in22,iel2)
  220.         END IF
  221.  
  222.         ideb = ipos(ia)+1
  223.         ifin = ipos(ia+1)
  224.         iel1 = 0
  225.         DO ie = ideb, ifin
  226.           ielz = inds(ie)
  227. C* On garde la position du 1er noeud pour le signe de la "face"
  228.           in21 = 0
  229.           DO in1 = 1, nbno1
  230.             IF (ipt1.num(in1,ielz).EQ.ia) THEN 
  231.               in21 = in1
  232.               GOTO 101
  233.             END IF
  234.           END DO
  235.           GOTO 110
  236.  101      CONTINUE
  237.           DO in1 = 1, nbno1
  238.             IF (ipt1.num(in1,ielz).EQ.ib) GOTO 102
  239.           END DO
  240.           GOTO 110
  241.  102      CONTINUE
  242.           IF (chopt(1:4).EQ.'CELL') THEN
  243.             DO inc = 3, nbno1
  244.               ic = ipt2.num(inc,iel2)
  245.               DO in1 = 1, nbno1
  246.                 IF (ipt1.num(in1,ielz).EQ.ic) GOTO 103
  247.               END DO
  248.               GOTO 110
  249.  103          CONTINUE
  250.             END DO
  251.           END IF
  252. C       OK pour cet element
  253.           iel1 = ielz
  254. C Face dans le meme sens ou non :
  255.           IF (chopt(1:2).EQ.'FA') THEN
  256.             IF (NBNO1.EQ.2) THEN
  257.               IF (in21.EQ.2) iel1 = -ielz
  258.             ELSE
  259.               in22 = MOD(in21,NBNO1) + 1
  260.               IF (ipt1.num(in22,ielz).EQ.ib) iel1 = -ielz
  261.             END IF
  262.           END IF
  263.           GOTO 1
  264.  110      CONTINUE
  265.         END DO
  266.  1      CONTINUE
  267.         mlent1.lect(2*jg2-1) = indli1
  268.         mlent1.lect(2*jg2  ) = iel1
  269.         IF (iel1.EQ.0) n_z = n_z + 1
  270. c-dbg      write(ioimp,*) '       EL1',iel1,ityp1,nbno1,indli1,'POUR jg2=',
  271. c-dbg     &               jg2,iel2
  272.       END DO
  273.  
  274.       IF (n_z.GT.0) THEN
  275.         write(ioimp,*) 'HHOLIM : FACES unreferenced',n_z
  276.         iret = 5
  277.       END IF
  278.  
  279.       IF (chopt(1:4).EQ.'FACE') THEN
  280.         mlenti.lect( 8) = mlent1
  281.       END IF
  282.       IF (chopt(1:4).EQ.'FAEL') THEN
  283.         mlenti.lect( 9) = mlent1
  284.       END IF
  285.       IF (chopt(1:4).EQ.'CELL') THEN
  286.         mlenti.lect(10) = mlent1
  287.       END IF
  288.  
  289. C*      SEGDES,...... <- On laisse les Segments actifs en Sortie
  290.  
  291. C      RETURN
  292.       END
  293.  
  294.  
  295.  

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