Télécharger la plaquette Cast3M


fr en

Télécharger hhoext.eso

Retour à la liste

Numérotation des lignes : 

hhoext

  1. C HHOEXT    SOURCE    OF166741  24/05/06    21:15:10     11082          
  2. C HHOEXT    SOURCE    FANDEUR                                           
  3. C
  4.       SUBROUTINE HHOEXT (IPMODL,chopt, IPOBJ,chobj, iret)
  5.  
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11.  
  12. -INC CCHHOPA
  13. -INC CCHHOPR
  14.  
  15. -INC SMCOORD
  16. -INC SMMODEL
  17. -INC SMELEME
  18. -INC SMLENTI
  19.  
  20.       CHARACTER*(*) chopt,chobj
  21.  
  22.       CHARACTER*(4) motopt
  23. c*      CHARACTER*(16) motHHO
  24.  
  25.       EXTERNAL LONG
  26.  
  27.       iret = 0
  28.       IPOBJ = 0
  29.       chobj = '__VIDE__'
  30.  
  31.       IF (IDIM.NE.2) THEN
  32.         iret = 5
  33.         RETURN
  34.       END IF
  35.  
  36.       n_z = LONG(chopt)
  37.       CALL CHCASS(chopt(1:n_z),1,chopt(1:n_z))
  38.       IF (chopt(1:4).NE.'HHO_') THEN
  39.         write(ioimp,*) 'HHOEXT: incorrect keyword ',chopt(1:4)
  40.         iret = 21
  41.         RETURN
  42.       END IF
  43.       motopt(1:4) = chopt(5:8)
  44.       IF ( (motopt.NE.'FACE') .AND. (motopt.NE.'PFAC') .AND.
  45.      &     (motopt.NE.'PCEL') ) THEN
  46.         write(ioimp,*) 'HHOEXT: incorrect keyword ',motopt
  47.         iret = 21
  48.         RETURN
  49.       END IF
  50.  
  51.       mmodel = IPMODL
  52. c*      segact,mmodel*nomod (segment actif en entree)
  53.       NSOUM = mmodel.kmodel(/1)
  54.  
  55.       NSOHHO = 0
  56.       DO im = 1, NSOUM
  57.         imodel = mmodel.kmodel(im)
  58.         IF (imodel.nefmod .EQ. HHO_NUM_ELEMENT) NSOHHO = NSOHHO + 1
  59.       END DO
  60.  
  61. C= Cas Particulier : pas de HHO dans le MMODEL -> Maillage VIDE
  62.       IF (NSOHHO.EQ.0) THEN
  63.         nbnn   = 1
  64.         nbelem = 0
  65.         nbsous = 0
  66.         nbref  = 0
  67.         SEGINI,ipt1
  68.         ipt1.itypel = 1
  69.         IPOBJ = ipt1
  70.         chobj = 'MAILLAGE'
  71.         RETURN
  72.       END IF
  73.  
  74. C= EXTRACTION DES POINTS SUPPORTS DES DDLS DES FACES / CELLULES :
  75.       IF ((motopt.EQ.'PFAC') .OR. (motopt.EQ.'PCEL')) THEN
  76.         IF (motopt.EQ.'PFAC') THEN
  77.           ipt2 = MPFHHO
  78.           iel1 = NFAHHO
  79.           indhho = 2
  80.         END IF
  81.         IF (motopt.EQ.'PCEL') THEN
  82.           ipt2 = MPCHHO
  83.           iel1 = NCEHHO
  84.           indhho = 4
  85.         END IF
  86. c*        segact,ipt2
  87.  
  88.         nbnn   = 1
  89.         nbelem = iel1
  90.         nbsous = 0
  91.         nbref  = 0
  92.         SEGINI,ipt1
  93.         ipt1.itypel = 1
  94.  
  95.         DO im = 1, NSOUM
  96.           imodel = mmodel.kmodel(im)
  97.           IF (imodel.nefmod .NE. HHO_NUM_ELEMENT) GOTO 100
  98.           CALL HHONOB(imodel,nobHHO,iret)
  99.           IF (nobHHO.LE.0) THEN
  100.             write(ioimp,*) 'HHOEXT: nobHHO undefined'
  101.             iret = 5
  102.             RETURN
  103.           END IF
  104.           IF (imodel.TYMODE(nobHHO+indHHO) .NE. 'LISTENTI') THEN
  105.             write(ioimp,*) 'HHOEXT: indHHO LISTENTI undefined'
  106.             iret = 5
  107.             RETURN
  108.           END IF
  109.           mlent3 = imodel.IVAMOD(nobHHO+indHHO)
  110.           SEGACT,mlent3
  111.           nbel3 = mlent3.lect(/1)
  112.           DO i = 2, nbel3, 2
  113.             je = mlent3.lect(i-1)
  114.             ip = ABS(mlent3.lect(i))
  115.       if (ip.eq.0) write(ioimp,*) 'HHOEXT P... Bizarre...',i/2,je,ip
  116.             IF (motopt.EQ.'PFAC') THEN
  117.               jp = ip + NBFHHO(je-1)
  118.             ELSE IF (motopt.EQ.'PCEL') THEN
  119.               jp = ip + NBCHHO(je-1)
  120.             END IF
  121.             ipt1.num(1,jp) = ipt2.num(1,jp)
  122.           END DO
  123.           SEGDES,mlent3
  124.  100      CONTINUE
  125.         END DO
  126. C= On compacte le maillage de POI1
  127.         iel1 = 0
  128.         DO i1 = 1, nbelem
  129.           IF (ipt1.num(1,i1).NE.0) THEN
  130.             iel1 = iel1 + 1
  131.             IF (iel1.NE.i1) THEN
  132.               ipt1.num(1,iel1) = ipt1.num(1,i1)
  133.               ipt1.num(1,i1) = 0
  134.             END IF
  135.           END IF
  136.         END DO
  137.         IF (iel1.LT.nbelem) THEN
  138.           nbelem = iel1
  139.           SEGADJ,ipt1
  140.         END IF
  141. C= Fin
  142. c*        SEGDES,ipt1
  143.         IPOBJ = ipt1
  144.         chobj = 'MAILLAGE'
  145.         RETURN
  146.       END IF
  147.  
  148. C= EXTRACTION DES FACES :
  149.       IF (chopt(5:8).EQ.'FACE') THEN
  150.         indHHO = 2
  151.         JG = NFAMAX
  152.         SEGINI,mlent1
  153.         DO i = 1, JG
  154.           mlent1.lect(i) = 0
  155.         END DO
  156. C= Preparation des donnees (MAILLAGE) : Maillage a "ZERO"
  157.         nbs = NUFHHO
  158.         IF (IDIM.EQ.2) THEN
  159.           ideb = 2
  160.           ifin = 2
  161.           if (nbs.ne.1) then
  162.             write(ioimp,*) 'HHOEXT: incompatibility 2D NFUHHO'
  163.             iret = 5
  164.             return
  165.           end if
  166.         END IF
  167.         IF (IDIM.EQ.3) THEN
  168.           ideb = 3
  169.           ifin = HHO_MAX_EDGE
  170.         END IF
  171.         isou = 0
  172.         DO i = ideb, ifin
  173.           nbelem = NBFHHO(i) - NBFHHO(i-1)
  174.           IF (nbelem.EQ.0) GOTO 200
  175.           isou = isou + 1
  176.           nbnn   = i
  177.           nbsous = 0
  178.           nbref  = 0
  179.           SEGINI,ipt1
  180.           ipt2 = MAFHHO(i)
  181.           segact,ipt2
  182.           ipt1.itypel = ipt2.itypel
  183. c*          segdes,ipt2
  184.           mlent1.lect(i) = ipt1
  185.  200      CONTINUE
  186.         END DO
  187.         IF (isou.NE.nbs) THEN
  188.           write(ioimp,*) 'HHOEXT(2): incompatibility NBSOUS'
  189.           iret = 5
  190.           return
  191.         END IF
  192.  
  193.         ISOHHO = 0
  194.         DO im = 1, NSOUM
  195.           imodel = mmodel.kmodel(im)
  196.           IF (imodel.nefmod .NE. HHO_NUM_ELEMENT) GOTO 250
  197.           CALL HHONOB(imodel, nobHHO, iret)
  198.           IF (nobHHO.LE.0) THEN
  199.             write(ioimp,*) 'HHOEXT : nobHHO undefined'
  200.             iret = 5
  201.             RETURN
  202.           END IF
  203.           IF (imodel.TYMODE(nobHHO+indHHO) .NE. 'LISTENTI') THEN
  204.             write(ioimp,*) 'HHOEXT : nobHHO+indHHO LISTENTI undefined'
  205.             iret = 5
  206.             RETURN
  207.           END IF
  208.           ISOHHO = ISOHHO + 1
  209.           mlent3 = imodel.IVAMOD(nobHHO+indHHO)
  210.           SEGACT,mlent3
  211.           nbel3 = mlent3.lect(/1)
  212.           DO i = 2, nbel3, 2
  213.             je = mlent3.lect(i-1)
  214.             ip = ABS(mlent3.lect(i))
  215.       if (ip.eq.0) write(ioimp,*) 'HHOEXT FACE Bizarre...',i/2,je,ip
  216.             ipt2 = MAFHHO(je)
  217.             ipt1 = mlent1.lect(je)
  218.             DO j = 1, je
  219.               ipt1.num(j,ip) = ipt2.num(j,ip)
  220.             END DO
  221.           END DO
  222.           SEGDES,mlent3
  223.  250      CONTINUE
  224.         END DO
  225. C= On compacte le maillage
  226.         isou = 0
  227.         DO i = 1, NFAMAX
  228.           ipt1 = mlent1.lect(i)
  229.           IF (ipt1.EQ.0) GOTO 270
  230.           nbnn1 = ipt1.num(/1)
  231.           nbel1 = ipt1.num(/2)
  232.           iel1 = 0
  233.           DO i1 = 1, nbel1
  234.             IF (ipt1.num(1,i1).NE.0) THEN
  235.               iel1 = iel1 + 1
  236.               IF (iel1.NE.i1) THEN
  237.                 DO j = 1, nbnn1
  238.                   ipt1.num(j,iel1) = ipt1.num(j,i1)
  239.                 END DO
  240.                 ipt1.num(1,i1) = 0
  241.               END IF
  242.             END IF
  243.           END DO
  244.           IF (iel1.EQ.0) THEN
  245.             SEGSUP,ipt1
  246.             mlent1.lect(i) = 0
  247.           ELSE
  248.             isou = isou + 1
  249.             IF (iel1.LT.nbel1) THEN
  250.               nbnn   = nbnn1
  251.               nbelem = iel1
  252.               nbsous = 0
  253.               nbref  = 0
  254.               SEGADJ,ipt1
  255.             END IF
  256.           END IF
  257.  270      CONTINUE
  258.         END DO
  259.         IF (isou.EQ.0) THEN
  260.           nbnn   = 1
  261.           nbelem = 0
  262.           nbsous = 0
  263.           nbref  = 0
  264.           SEGINI,ipt2
  265.           ipt2.itypel = 1
  266.         ELSE IF (isou.EQ.1) THEN
  267.           DO i = 1, NFAMAX
  268.             ipt1 = mlent1.lect(i)
  269.             IF (ipt1.NE.0) ipt2 = ipt1
  270.           END DO
  271.         ELSE
  272.           nbnn   = 0
  273.           nbelem = 0
  274.           nbsous = isou
  275.           nbref  = 0
  276.           SEGINI,ipt2
  277.           jsou = 0
  278.           DO i = 1, NFAMAX
  279.             ipt1 = mlent1.lect(i)
  280.             IF (ipt1.NE.0) THEN
  281.               jsou = jsou + 1
  282.               ipt2.lisous(jsou) = ipt1
  283.             END IF
  284.           END DO
  285.           if (isou.ne.jsou) then
  286.             write(ioimp,*) 'HHOEXT FACE : incompatibility isou-jsou'
  287.           end if
  288.         END IF
  289.         SEGSUP,mlent1
  290.         IPOBJ = ipt2
  291.         chobj = 'MAILLAGE'
  292.         RETURN
  293.       END IF
  294.  
  295. C*      RETURN
  296.       END
  297.  
  298.  
  299.  

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