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/12/18    21:15:14     12092          
  2.  
  3.       SUBROUTINE HHOEXT (IPMODL,chopt, IPOBJ,chobj, iret)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10.  
  11. -INC CCHHOPA
  12. -INC CCHHOPR
  13.  
  14. -INC SMCOORD
  15. -INC SMMODEL
  16. -INC SMELEME
  17. -INC SMLENTI
  18.  
  19.       CHARACTER*(*) chopt,chobj
  20.  
  21.       CHARACTER*(4) motopt
  22. c*      CHARACTER*(16) motHHO
  23.  
  24.       EXTERNAL LONG
  25.  
  26.       iret = 0
  27.       IPOBJ = 0
  28.       chobj = '__VIDE__'
  29.  
  30.       IF (IDIM.NE.2) THEN
  31.         iret = 5
  32.         RETURN
  33.       END IF
  34.  
  35.       n_z = LONG(chopt)
  36.       CALL CHCASS(chopt(1:n_z),1,chopt(1:n_z))
  37.       IF (chopt(1:4).NE.'HHO_') THEN
  38.         write(ioimp,*) 'HHOEXT: incorrect keyword ',chopt(1:4)
  39.         iret = 21
  40.         RETURN
  41.       END IF
  42.       motopt(1:4) = chopt(5:8)
  43.       IF ( (motopt.NE.'FACE') .AND. (motopt.NE.'PFAC') .AND.
  44.      &     (motopt.NE.'PCEL') ) THEN
  45.         write(ioimp,*) 'HHOEXT: incorrect keyword ',motopt
  46.         iret = 21
  47.         RETURN
  48.       END IF
  49.  
  50.       mmodel = IPMODL
  51. c*      segact,mmodel*nomod (segment actif en entree)
  52.       NSOUM = mmodel.kmodel(/1)
  53.  
  54.       NSOHHO = 0
  55.       DO im = 1, NSOUM
  56.         imodel = mmodel.kmodel(im)
  57.         IF (imodel.nefmod .EQ. HHO_NUM_ELEMENT) NSOHHO = NSOHHO + 1
  58.       END DO
  59.  
  60. C= Cas Particulier : pas de HHO dans le MMODEL -> Maillage VIDE
  61.       IF (NSOHHO.EQ.0) THEN
  62.         nbnn   = 1
  63.         nbelem = 0
  64.         nbsous = 0
  65.         nbref  = 0
  66.         SEGINI,ipt1
  67.         ipt1.itypel = 1
  68.         IPOBJ = ipt1
  69.         chobj = 'MAILLAGE'
  70.         RETURN
  71.       END IF
  72.  
  73. C= EXTRACTION DES POINTS SUPPORTS DES DDLS DES FACES / CELLULES :
  74.       IF ((motopt.EQ.'PFAC') .OR. (motopt.EQ.'PCEL')) THEN
  75.         IF (motopt.EQ.'PFAC') THEN
  76.           ipt2 = MPFHHO
  77.           iel1 = NFAHHO
  78.           indhho = 2
  79.         END IF
  80.         IF (motopt.EQ.'PCEL') THEN
  81.           ipt2 = MPCHHO
  82.           iel1 = NCEHHO
  83.           indhho = 4
  84.         END IF
  85.         segact,ipt2
  86.  
  87.         nbnn   = 1
  88.         nbelem = iel1
  89.         nbsous = 0
  90.         nbref  = 0
  91.         SEGINI,ipt1
  92.         ipt1.itypel = 1
  93.  
  94.         DO im = 1, NSOUM
  95.           imodel = mmodel.kmodel(im)
  96.           IF (imodel.nefmod .NE. HHO_NUM_ELEMENT) GOTO 100
  97.           CALL HHONOB(imodel,nobHHO,iret)
  98.           IF (nobHHO.LE.0) THEN
  99.             write(ioimp,*) 'HHOEXT: nobHHO undefined'
  100.             iret = 5
  101.             RETURN
  102.           END IF
  103.           IF (imodel.TYMODE(nobHHO+indHHO) .NE. 'LISTENTI') THEN
  104.             write(ioimp,*) 'HHOEXT: indHHO LISTENTI undefined'
  105.             iret = 5
  106.             RETURN
  107.           END IF
  108.           mlent3 = imodel.IVAMOD(nobHHO+indHHO)
  109.           SEGACT,mlent3
  110.           nbel3 = mlent3.lect(/1)
  111.           DO i = 2, nbel3, 2
  112.             je = mlent3.lect(i-1)
  113.             ip = ABS(mlent3.lect(i))
  114.       if (ip.eq.0) write(ioimp,*) 'HHOEXT P... Bizarre...',i/2,je,ip
  115.             IF (motopt.EQ.'PFAC') THEN
  116.               jp = ip + NBFHHO(je-1)
  117.             ELSE IF (motopt.EQ.'PCEL') THEN
  118.               jp = ip + NBCHHO(je-1)
  119.             END IF
  120.             ipt1.num(1,jp) = ipt2.num(1,jp)
  121.           END DO
  122.           SEGDES,mlent3
  123.  100      CONTINUE
  124.         END DO
  125. C= On compacte le maillage de POI1
  126.         iel1 = 0
  127.         DO i1 = 1, nbelem
  128.           IF (ipt1.num(1,i1).NE.0) THEN
  129.             iel1 = iel1 + 1
  130.             IF (iel1.NE.i1) THEN
  131.               ipt1.num(1,iel1) = ipt1.num(1,i1)
  132.               ipt1.num(1,i1) = 0
  133.             END IF
  134.           END IF
  135.         END DO
  136.         IF (iel1.LT.nbelem) THEN
  137.           nbelem = iel1
  138.           SEGADJ,ipt1
  139.         END IF
  140. C= Fin
  141. c*        SEGDES,ipt1
  142.         IPOBJ = ipt1
  143.         chobj = 'MAILLAGE'
  144. c*        segdes,ipt2
  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