Télécharger la plaquette Cast3M


fr en

Télécharger hhopre.eso

Retour à la liste

Numérotation des lignes : 

hhopre

  1. C HHOPRE    SOURCE    OF166741  24/05/06    21:15:13     11082          
  2. C HHOPRE    SOURCE                                                      
  3.  
  4.       SUBROUTINE HHOPRE (charHHO, mailHHO, 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 SMCOORD
  17. -INC SMELEME
  18. -INC SMLENTI
  19.       POINTEUR mleCEL.mlenti,mleSQE.mlenti
  20.  
  21.       EXTERNAL LONG
  22.  
  23.       CHARACTER*(*) charHHO
  24.       CHARACTER*(3) hyp_z
  25.  
  26.       iret = 0
  27.  
  28. C=----------------------------------------------------------------------
  29. C= ORDRE DES CELLULES ET DES FACES :
  30. C=----------------------------------------------------------------------
  31. C= Decodage de la chaine pour avoir ordre des cellules et des faces :
  32.       n_z = LONG(charHHO)
  33.       l_z = LEN(charHHO)
  34. c-AV      IF (l_z.LT.13) THEN
  35.       IF (l_z.LT.11) THEN
  36.         write(ioimp,*) 'LENGTH charHHO incorrect (PBM 10)'
  37.         iret = 5
  38.         RETURN
  39.       END IF
  40. C= Passage en minuscules :
  41.       CALL CHCASS(charHHO(1:n_z),0,charHHO(1:n_z))
  42. C= Transformation des " " en "_" --> "hho_c_f" ou "hho_c_f_hyp" ?
  43.       DO i = 1, n_z
  44.         IF (charHHO(i:i).EQ.' ') charHHO(i:i) = '_'
  45.       END DO
  46. c-dbg      write(ioimp,*) 'charHHO =>'//charHHO(1:n_z)//'<=',n_z,l_z
  47. C= La chaine charHHO doit etre de la forme :
  48. C= "hho_c_f" ou "hho_c_f_hyp" avec c et f entiers positifs, et hyp=sp/ft
  49. C= Petits tests :
  50.       IF (n_z.LT.7) THEN
  51.         write(ioimp,*) 'String HHO too short (PBM 0)'
  52.         iret = 5
  53.         RETURN
  54.       END IF
  55.       IF (charHHO(1:3).NE.'hho') THEN
  56.         write(ioimp,*) 'String HHO incorrect (PBM 1)'
  57.         iret = 21
  58.         RETURN
  59.       END IF
  60.       i_c = INDEX(charHHO(1:n_z),'_')
  61.       IF (i_c.NE.4) THEN
  62.         write(ioimp,*) 'String HHO incorrect (PBM 2)',i_c
  63.         iret = 21
  64.         RETURN
  65.       END IF
  66.       i_f = INDEX(charHHO(i_c+1:n_z),'_')
  67.       IF (i_f.LT.1) THEN
  68.         write(ioimp,*) 'Sring HHO incorrect (PBM 3)',i_f
  69.         iret = 21
  70.         RETURN
  71.       END IF
  72.       i_f = i_f + i_c
  73.       i_h = INDEX(charHHO(i_f+1:n_z),'_')
  74.       IF (i_h.LT.1) THEN
  75.         i_h = n_z + 1
  76.         i_3 = 0
  77.       ELSE
  78.         i_h = i_f + i_h
  79.         i_3 = n_z
  80.       ENDIF
  81. c-dbg      write(ioimp,*) 'HHOPRE 1 ',i_c,i_f,i_h,i_3
  82.  
  83.       i_z = (i_f - 1) - (i_c + 1) + 1
  84.       IF (i_z.LT.1) THEN
  85.         write(ioimp,*) 'CELL ORDER undefined (PBM 4)'
  86.         iret = 21
  87.         RETURN
  88.       END IF
  89.       i_z = (i_h - 1) - (i_f + 1) + 1
  90.       IF (i_z.LT.1) THEN
  91.         write(ioimp,*) 'FACE ORDER undefined (PBM 5)'
  92.         iret = 21
  93.         RETURN
  94.       END IF
  95.  
  96.       n_o_cell = -999
  97.       n_o_face = -999
  98.       READ(charHHO(i_c+1:i_f-1),*,ERR=901) n_o_cell
  99.  901  CONTINUE
  100.       READ(charHHO(i_f+1:i_h-1),*,ERR=902) n_o_face
  101.  902  CONTINUE
  102.       IF (n_o_cell.LT.0 .OR. n_o_face.LT.0) THEN
  103.         write(ioimp,*) 'CELL/FACE ORDER incorrect (PBM 6)'
  104.         write(ioimp,*) '   =>',charHHO(i_c+1:i_f-1),'<=',
  105.      &                 '   =>',charHHO(i_f+1:i_h-1),'<='
  106.         iret = 21
  107.         RETURN
  108.       END IF
  109. C= Test de coherence :
  110.       IF (IDIM.EQ.1) THEN
  111.         IF (n_o_face.NE.0) THEN
  112.           write(ioimp,*) 'IDIM = 1 : FACE ORDER must be 0 (PBM 7)'
  113.           iret = 21
  114.         END IF
  115.       END IF
  116.       IF ( (IDIM.EQ.2) .OR. (IDIM.EQ.3) ) THEN
  117.         IF ( n_o_cell.LT.(n_o_face-1) .OR.
  118.      &       n_o_cell.GT.(n_o_face+1) ) THEN
  119.           write(ioimp,*) 'IDIM = 2/3 : CELL ORDER uncorrect (PBM 8)'
  120.           write(ioimp,*) '  l cell in [ k face - 1 ; k face + 1]'
  121.           iret = 21
  122.         END IF
  123.       END IF
  124. C= Validation de l'hypothese de calcul ("sp" ou "ft")
  125.       IF (i_3.GT.0) THEN
  126.         hyp_z = '   '
  127.         hyp_z = charHHO(i_h:n_z)
  128.         IF (hyp_z.NE.'_ft' .AND. hyp_z.NE.'_sp') THEN
  129.           write(ioimp,*) 'HYPOTHESIS SP/FT incorrect (PBM 9)'
  130.           iret = 21
  131.           RETURN
  132.         END IF
  133.       ELSE
  134.         hyp_z = '_sp'
  135.       END IF
  136. *AV      charHHO(1:13) = 'hho_00_00_** '
  137. *AV      WRITE(charHHO(5:6),'(I2.2)') n_o_cell
  138. *AV      WRITE(charHHO(8:9),'(I2.2)') n_o_face
  139. *AV      charHHO(10:12) = hyp_z
  140. *AVC= La chaine charHHO est de la forme : "hho_cc_ff_hy ".
  141.       charHHO(1:11) = 'hho_0_0_** '
  142.       WRITE(charHHO(5:5),'(I1.1)') n_o_cell
  143.       WRITE(charHHO(7:7),'(I1.1)') n_o_face
  144.       charHHO(8:10) = hyp_z
  145. C= La chaine charHHO est de la forme : "hho_c_f_hy ".
  146. C= Elle sera utile pour appeler les fonctions HHO adequates.
  147.  
  148. C= Nombre de ddl par face et par cellule selon ordre et dime
  149. C= Attention pour les faces : dime = idim - 1 !
  150. C= nddl_dir = Produit(i = 1 a dime) [ (ordre + dime + 1 - i) / i ]
  151.       IF (IDIM.EQ.1) THEN
  152.         n_d_face = 1
  153.         n_d_cell = n_o_cell + 1
  154.       ELSE IF (IDIM.EQ.2) THEN
  155.         n_d_face = n_o_face + 1
  156.         n_d_cell = (n_o_cell + 2) * (n_o_cell + 1) / 2
  157.       ELSE IF (IDIM.EQ.3) THEN
  158.         n_d_face = (n_o_face + 2) * (n_o_face + 1) / 2
  159.         n_d_cell = (n_o_face + 3) * (n_o_face + 2) * (n_o_face + 1) / 6
  160.       END IF
  161. C= nddl tot = nddl_dir * idfo (idfo = idim pour MECA, = 1 pour THER ou PFM)
  162.  
  163. C= Quelques restrictions qui pourront etre levees par la suite :
  164.       IF (n_o_face.NE.1) THEN
  165.         write(ioimp,*) 'FACE ORDER must be equal to 1 for the moment'
  166.         iret = 21
  167.         RETURN
  168.       END IF
  169.       IF (n_d_face.GT.10) THEN
  170.         write(ioimp,*) 'FACE ORDER is too big (PBM 12F)'
  171.         iret = 21
  172.         RETURN
  173.       END IF
  174.       IF (n_d_cell.GT.10) THEN
  175.         write(ioimp,*) 'CELL ORDER is too big (PBM 12C)'
  176.         iret = 21
  177.         RETURN
  178.       END IF
  179.  
  180. c-dbg      write(ioimp,*)
  181. c-dbg      write(ioimp,*) 'HHO : IDIM, IFOUR =', IDIM,IFOUR
  182. c-dbg      write(ioimp,*) '      =>'//charHHO(1:LONG(charHHO))//'<='
  183. c-dbg      write(ioimp,*) '      FACE ORDER / DOF DIR = ',n_o_face,n_d_face
  184. c-dbg      write(ioimp,*) '      CELL ORDER / DOF DIR = ',n_o_cell,n_d_cell
  185. c-dbg      write(ioimp,*) '      HYPOTHESIS = ', hyp_z(2:3)
  186.  
  187. C=----------------------------------------------------------------------
  188. C= Traitement du maillage total du modele (fourni en entree) :
  189. C=----------------------------------------------------------------------
  190.       meleme  = mailHHO
  191. c*      segact,meleme*nomod (segment actif en entree)
  192.  
  193. C=----------------------------------------------------------------------
  194. C= Construction du maillage des faces :
  195. C=----------------------------------------------------------------------
  196.       CALL ECROBJ('MAILLAGE',mailHHO)
  197.       IF (IDIM.EQ.2) THEN
  198.         CALL CHANLG
  199.       ELSE IF (IDIM.EQ.3) THEN
  200.         CALL ECRCHA('NOID')
  201.         CALL ENVVO2(1)
  202.       ELSE
  203.         IERR = 5
  204.       END IF
  205.       IF (IERR.NE.0) THEN
  206.         iret = 21
  207.         RETURN
  208.       END IF
  209.       CALL LIROBJ('MAILLAGE',mailSQE,1,iretc)
  210.  
  211. C= On reactive les maillages :
  212.       CALL ACTOBJ('MAILLAGE',mailHHO,1)
  213.       CALL ACTOBJ('MAILLAGE',mailSQE,1)
  214.  
  215. C= ---------------------------
  216. C= Compatibilite des maillages avec la formulation HHO
  217. C= ---------------------------
  218. C= Les elements geometriques (cellules/faces) autorises :
  219.       IF (IDIM.EQ.3) THEN
  220.         indc = IC3MAX+1
  221.         lonc = NC3MAX
  222.         indf = IF3MAX+1
  223.         lonf = NF3MAX
  224.       ELSE IF (IDIM.EQ.2) THEN
  225.         indc = IC2MAX+1
  226.         lonc = NC2MAX
  227.         indf = IF2MAX+1
  228.         lonf = NF2MAX
  229. c-      ELSE IF (IDIM.EQ.1) THEN
  230.       ELSE
  231.         indc = IC1MAX+1
  232.         lonc = NC1MAX
  233.         indf = IF1MAX+1
  234.         lonf = NF1MAX
  235.       END IF
  236.  
  237. C= Verifications du maillage :
  238. C= ---------------------------
  239.       meleme  = mailHHO
  240.       nbsCEL = meleme.LISOUS(/1)
  241.       ipt1 = meleme
  242.       nbs1 = MAX(1,nbsCEL)
  243.       n_z = 0
  244.       DO i = 1, nbs1
  245.         IF (nbsCEL.NE.0) ipt1 = meleme.LISOUS(i)
  246.         ity1 = ipt1.itypel
  247.         if (ity1.eq.32) ity1 = ity1 * 100 + ipt1.num(/1)
  248.         i_z = 0
  249.         CALL PLACE2(LICHHO(indc),lonc,i_z,ity1)
  250.         IF (i_z.EQ.0) THEN
  251.           write(ioimp,*) 'HHOPRE: cell not defined',ipt1,NOMS(ity1),ity1
  252.           n_z = n_z + 1
  253.         END IF
  254.       END DO
  255.       IF (n_z.GT.0) THEN
  256.         iret = 251
  257.         RETURN
  258.       END IF
  259.  
  260.       meleme = mailSQE
  261.       nbsSQE = meleme.lisous(/1)
  262.       if (nbsSQE.ne.0) then
  263.         IF (IDIM.EQ.1 .OR. IDIM.EQ.2) THEN
  264.           write(ioimp,*) 'HHO 1D/2D : skeleton not simple'
  265.           iret = 5
  266.           return
  267.         END IF
  268.       end if
  269.       ipt1 = meleme
  270.       nbs1 = MAX(1,nbsSQE)
  271.       n_z = 0
  272.       DO i = 1, nbs1
  273.         IF (nbsSQE.NE.0) ipt1 = meleme.lisous(i)
  274.         ity1 = ipt1.itypel
  275. c*face3Dpoly : inconnu a ce jour       if (ity1.eq.  ) ity1 = formule a ecrire si necessaire
  276.         i_z = 0
  277.         CALL PLACE2(LIFHHO(indf),lonf,i_z,ity1)
  278.         IF (i_z.EQ.0) THEN
  279.           write(ioimp,*) 'HHOPRE: face not defined',ipt1,NOMS(ity1),ity1
  280.           n_z = n_z + 1
  281.         END IF
  282.       END DO
  283.       IF (n_z.GT.0) THEN
  284.         iret = 5
  285.         RETURN
  286.       END IF
  287.  
  288. C=----------------------------------------------------------------------
  289. C= Initialisations/Verifications DIMENSION et MODE DE CALCUL HHO
  290. C=----------------------------------------------------------------------
  291.       i1_HHO = 0
  292.       IF (IDIHHO.LT.0) THEN
  293.         i1_HHO = 1
  294.         IDIHHO = IDIM
  295.         IFOHHO = IFOUR
  296.       END IF
  297.       IF (IDIHHO .NE. IDIM) THEN
  298.         write(ioimp,*) 'HHOPRE: IDIM cannot be changed'
  299.         iret = 5
  300.         RETURN
  301.       END IF
  302.       IF (IFOHHO .NE. IFOUR) THEN
  303.         write(ioimp,*) 'HHOPRE: IFOUR cannot be changed'
  304.         iret = 5
  305.         RETURN
  306.       END IF
  307.  
  308. C- Juste pour le debogage :
  309.       if (nbchho(0).ne.0) then
  310.         write(ioimp,*) 'HHOPRE: nbchho(0) not 0'
  311.         iret = 5
  312.       end if
  313.       if (nbfhho(0).ne.0) then
  314.         write(ioimp,*) 'HHOPRE: nbfhho(0) not 0'
  315.         iret = 5
  316.       end if
  317.       if (iret.ne.0) return
  318.  
  319. c-dbg c Si on souhaite surveiller un maillage
  320. c-dbg      CALL OOOSUR(M..HHO)
  321. c-dbg      msurve = M...HO
  322.  
  323. C= Construction du maillage HHO global MCEHHO :
  324. C= --------------------------------------------
  325.       JG = 2 * NCEMAX
  326.       SEGINI,mleCEL
  327.       DO i = 1, NCEMAX
  328.         mleCEL.lect(i) = NBCHHO(i)
  329.         mleCEL.lect(i+NCEMAX) = 0
  330.       END DO
  331.  
  332. C= Remplissage initial de MCEHHO :
  333.       IF (MCEHHO.LT.0) THEN
  334. c-dbg        write(ioimp,*) 'HHOPRE: Initialisation MCEHHO'
  335. C= Petites verifications juste pour le debogage :
  336.         if (i1_HHO.NE.1) then
  337.           write(ioimp,*) 'HHOPRE-MCEHHO: Bad initialization (1)'
  338.           iret = 5
  339.           return
  340.         end if
  341.         n_z = 0
  342.         DO i = 1, NCEMAX
  343.           IF (MACHHO(i).GT.0 .OR. NBCHHO(i).NE.0) THEN
  344.             n_z = n_z + 1
  345.             write(ioimp,*) 'HHOPRE-MCEHHO: Init.',i,MACHHO(i),NBCHHO(i)
  346.           END IF
  347.         END DO
  348.         if (n_z.gt.0) then
  349.           iret = 5
  350.           return
  351.         end if
  352.  
  353. C- Si plusieurs zones, on duplique entete du maillage
  354.         IF (nbsCEL.GT.1) THEN
  355.           ipt1 = mailHHO
  356.           SEGINI,meleme=ipt1
  357.           MCEHHO = meleme
  358.         ELSE
  359.           MCEHHO = mailHHO
  360.         END IF
  361.  
  362.         meleme = MCEHHO
  363.         ipt1 = meleme
  364.         nbs1 = MAX(1,nbsCEL)
  365.         DO i = 1, nbs1
  366.           IF (nbsCEL.NE.0) ipt1 = meleme.lisous(i)
  367.           ity1 = ipt1.itypel
  368.           if (ity1.eq.32) ity1 = ity1 * 100 + ipt1.num(/1)
  369.           i_z = 0
  370.           CALL PLACE2(LICHHO(indc),lonc,i_z,ity1)
  371.           nbe1 = ipt1.num(/2)
  372. c* a revoir quand il y aura cumul
  373.           NBCHHO(i_z) = nbe1
  374.           MACHHO(i_z) = ipt1
  375.           if (mleCEL.lect(i_z+NCEMAX).ne.0)
  376.      &      write(ioimp,*) 'HHOPRE: bizarre',i,i_z,ipt1,ity1
  377.           mleCEL.lect(i_z+NCEMAX) = nbe1
  378.         END DO
  379.  
  380. C= Mise a jour de MCEHHO :
  381.       ELSE
  382.         if (i1_HHO.NE.0) then
  383.           write(ioimp,*) 'HHOPRE-MCEHHO: Bad initialization (2)'
  384.           iret = 5
  385.           return
  386.         end if
  387.         write(ioimp,*) 'MCEHHO deja defini --> A completer'
  388.         write(ioimp,*) 'MAIS CAS EN COURS D IMPLEMENTATION'
  389.         iret = 5
  390.         RETURN
  391.       END IF
  392.  
  393.       nelCEL = 0
  394.       nbsCEL = 0
  395.       DO i = 1, NCEMAX
  396.         nelCEL = nelCEL + NBCHHO(i)
  397.         IF (MACHHO(i).GT.0) nbsCEL = nbsCEL + 1
  398.       END DO
  399.       NCEHHO = nelCEL
  400.       NUCHHO = nbsCEL
  401. c-dbg      write(ioimp,*) 'HHOPRE-MCEHHO:',NCEHHO,NUCHHO
  402.  
  403. C* On reordonne MCEHHO selon liste type :
  404.       ipt2 = MCEHHO
  405.       IF (nbsCEL.GT.1) THEN
  406.         segact,ipt2*MOD
  407.         isou = 0
  408.         DO i = 1, NCEMAX
  409.           ipt1 = MACHHO(i)
  410.           IF (ipt1.GT.0) THEN
  411.             isou = isou + 1
  412.             ipt2.lisous(isou) = ipt1
  413.           END IF
  414.         END DO
  415.         segact,ipt2*NOMOD
  416.       END IF
  417. C= Doit-on faire un savseg de MCEHHO et des sous-zones eventuelles ?
  418.       DO i = 1, NCEMAX
  419.         NBCHHO(i) = NBCHHO(i) + NBCHHO(i-1)
  420.       END DO
  421.       if (nbchho(ncemax).ne.NCEHHO)
  422.      &  write(ioimp,*) 'Bizarre nbchho(ncemax) != NCEHHO'
  423.  
  424. C= Construction du squelette HHO global MSQHHO :
  425. C= ---------------------------------------------
  426. c== Remplissage de ...HHO : l'indice i correspond aux donnees des faces
  427. C== qui sont des polygones a i cotes (indice =1 fixe a 0, =2 pour 2D, 
  428. C== =3 et superieurs pour 3D, limite = faces a moins de nfhmax cotes)
  429.       IF (IDIM.EQ.3) THEN
  430.         idebf = 3
  431.         ifinf = NFAMAX
  432.       ELSE IF (IDIM.EQ.2) THEN
  433.         idebf = 2
  434.         ifinf = 2
  435.       ELSE IF (IDIM.EQ.1) THEN
  436.         idebf = 1
  437.         ifinf = 1
  438.       END IF
  439.  
  440.       JG = 2 * NFAMAX
  441.       SEGINI,mleSQE
  442.       DO i = 1, NFAMAX
  443.         mleSQE.lect(i) = NBFHHO(i)
  444.         mleSQE.lect(i+NFAMAX) = 0
  445.       END DO
  446.  
  447. C= Remplissage initial de MSQHHO :
  448.       IF (MSQHHO.LT.0) THEN
  449. c-dbg        write(ioimp,*) 'HHOPRE: Initialisation MSQHHO'
  450. C= Petites verifications juste pour le debogage :
  451.         if (i1_HHO.NE.1) then
  452.           write(ioimp,*) 'HHOPRE-MSQHHO: Bad initialization (1)'
  453.           iret = 5
  454.           return
  455.         end if
  456.         n_z = 0
  457.         DO i = 1, NFAMAX
  458.           IF (MAFHHO(i).GT.0 .OR. NBFHHO(i).NE.0) THEN
  459.             n_z = n_z + 1
  460.             write(ioimp,*) 'HHOPRE-MSQHHO: Init.',i,MAFHHO(i),NBFHHO(i)
  461.           END IF
  462.         END DO
  463.         if (n_z.gt.0) then
  464.           iret = 5
  465.           return
  466.         end if
  467.  
  468. C- Si plusieurs zones, on duplique entete du maillage
  469.         IF (nbsSQE.GT.1) THEN
  470.           ipt1 = mailSQE
  471.           SEGINI,meleme=ipt1
  472.           MSQHHO = meleme
  473.         ELSE
  474.           MSQHHO = mailSQE
  475.         END IF
  476.  
  477.         meleme = mailSQE
  478.         ipt1 = meleme
  479.         nbs1 = MAX(1,nbsSQE)
  480.         DO i = 1, nbs1
  481.           IF (nbsSQE.NE.0) ipt1 = meleme.lisous(i)
  482.           nbn1 = ipt1.num(/1)
  483.           nbe1 = ipt1.num(/2)
  484.           if (mleSQE.lect(NFAMAX+nbn1).ne.0)
  485.      &      write(ioimp,*) 'HHOPRE: bizarre SQE',i,nb1,ipt1,nbe1
  486.           mleSQE.lect(NFAMAX+nbn1) = nbe1
  487.           JG = 2
  488.           SEGINI,mlent1
  489.           mlent1.lect(1) = -nbe1
  490.           mlent1.lect(2) = n_o_face
  491.           NBFHHO(nbn1) = nbe1
  492.           MAFHHO(nbn1) = ipt1
  493.           LOFHHO(nbn1) = mlent1
  494.         END DO
  495.  
  496. C= Mise a jour de MSQHHO :
  497.       ELSE
  498.         if (i1_HHO.NE.0) then
  499.           write(ioimp,*) 'HHOPRE-MSQHHO: Bad initialization (2)'
  500.           iret = 5
  501.           return
  502.         end if
  503.         write(ioimp,*) 'MSQHHO deja definie --> A completer'
  504.         write(ioimp,*) 'MAIS CAS EN COURS D IMPLEMENTATION'
  505.         iret = 5
  506.         RETURN
  507.  
  508. C----        meleme = mailSQE
  509. C----        ipt1 = meleme
  510. C----        DO i = 1, MAX(1,nbsSQE)
  511. C----          IF (nbsSQE.NE.0) ipt1 = meleme.lisous(i)
  512. C----          nbn1 = ipt1.num(/1)
  513. C----          nbe1 = ipt1.num(/2)
  514. C----          IF (MAFHHO(nbn1).GT.0) THEN
  515. C----* il faut fusionner les maillages de maniere unique...
  516. C----* en n'ajoutant que les nouvelles faces a la suite des existantes !
  517. C----            ipt2   = MAFHHO(nbn1)
  518. C----            mlent2 = LOFHHO(nbn1)
  519. C----            segact,mlent2*MOD
  520. C----            iadj2 = 0
  521. C----            IF (mlent2.lect(1).LT.0) THEN
  522. C----            END IF
  523. C----c*            CALL INTERB(ipt2,ipt1,ipti,ivid)
  524. C----c*            CALL OUEXCL(ipt1,ipti,iptc,ivid)
  525. C----c*            nbec = iptc.num(/2)
  526. C----c*            CALL FUSMAIL(ipt2,iptc,ipt3,ivid)
  527. C----c*
  528. C----c*            nbe1 = nbe1 + nbec
  529. C----          ELSE
  530. C----            JG = 2
  531. C----            SEGINI,mlent1
  532. C----            mlent1.lect(1) = -nbe1
  533. C----            mlent1.lect(2) = n_o_face
  534. C----          END IF
  535. C----          NBFHHO(nbn1) = nbe1
  536. C----          MAFHHO(nbn1) = ipt1
  537. C----          LOFHHO(nbn1) = mlent1
  538. C----        END DO
  539. C----
  540. C----        nbs1 = 0
  541. C----        DO i = idebf, ifinf
  542. C----          IF (MAFHHO(i).GT.0) nbs1 = nbs1 + 1
  543. C----        END DO
  544. C----        if (nbs1.le.0) then
  545. C----          write(ioimp,*) 'HHOPRE : MSQHHO update incorrect (1)'
  546. C----          iret = 5
  547. C----          return
  548. C----        end if
  549. C----        if (nbs1.lt.MAX(1,nbsSQE)) then
  550. C----          write(ioimp,*) 'HHOPRE : MSQHHO update incorrect (2)'
  551. C----          iret = 5
  552. C----          return
  553. C----        end if
  554.       END IF
  555.  
  556. C= Verification du tableau NBFHHO
  557.       IF (IDIM.EQ.1) THEN
  558.         if (nbfhho(1).le.0) then
  559.           write(ioimp,*) 'HHOPRE: no POI1 in DIME 1?'
  560.           iret = 5
  561.         end if
  562.         do i = 2, NFAMAX
  563.           if (nbfhho(i).gt.0) then
  564.             write(ioimp,*) 'HHOPRE:',i,'-side face in DIME 1'
  565.             iret = 5
  566.           end if
  567.         end do
  568.       END IF
  569.       IF (IDIM.EQ.2) THEN
  570.         if (nbfhho(1).ne.0) then
  571.           write(ioimp,*) 'HHOPRE: POI1 in DIME 2'
  572.           iret = 5
  573.         end if
  574.         NBFHHO(1) = 0
  575.         if (nbfhho(2).le.0) then
  576.           write(ioimp,*) 'HHOPRE: no SEG2 in DIME 2 ?'
  577.           iret = 5
  578.         end if
  579.         do i = 3, NFAMAX
  580.           if (nbfhho(i).gt.0) then
  581.             write(ioimp,*) 'HHOPRE: polygonal face in DIME 2',i,' sides'
  582.             iret = 5
  583.           end if
  584.         end do
  585.       END IF
  586.       IF (IDIM.EQ.3) THEN
  587.         if (nbfhho(1).ne.0) then
  588.           write(ioimp,*) 'HHOPRE: POI1 in DIME 3 ?'
  589.           iret = 5
  590.         end if
  591.         if (nbfhho(2).ne.0) then
  592.           write(ioimp,*) 'HHOPRE: SEG2 in DIME 3 ?'
  593.           iret = 5
  594.         end if
  595.         NBFHHO(1) = 0
  596.         NBFHHO(2) = 0
  597.       END IF
  598.       if (iret.gt.0) return
  599.  
  600.       nfaSQE = 0
  601.       nbsSQE = 0
  602.       DO i = idebf, ifinf
  603.         nfaSQE = nfaSQE + NBFHHO(i)
  604.         IF (MAFHHO(i).GT.0) nbsSQE = nbsSQE + 1
  605.       END DO
  606.       NFAHHO = nfaSQE
  607.       NUFHHO = nbsSQE
  608. c-dbg      write(ioimp,*) 'HHOPRE-MSQHHO:',NFAHHO,NUFHHO
  609.  
  610. C* On reordonne MSQHHO par faces de sommets croissants :
  611.       ipt2 = MSQHHO
  612.       IF (nbsSQE.GT.1) THEN
  613.         segact,ipt2*MOD
  614.         isou = 0
  615.         DO i = idebf, ifinf
  616.           ipt1 = MAFHHO(i)
  617.           IF (ipt1.GT.0) THEN
  618.             isou = isou + 1
  619.             ipt2.lisous(isou) = ipt1
  620.           END IF
  621.         END DO
  622.         segact,ipt2*NOMOD
  623.       END IF
  624. C= Doit-on faire un savseg de MSQHHO et des sous-zones eventuelles ?
  625.  
  626.       NBNN   = 1
  627.       NBELEM = NCEHHO
  628.       NBSOUS = 0
  629.       NBREF  = 0
  630.       IF (i1_HHO.EQ.1) THEN
  631. c-dbg        write(ioimp,*) 'HHOPRE: Initialisation MPCHHO',NCEHHO
  632.         SEGINI,ipt2
  633.         ipt2.itypel = 1
  634.         MPCHHO = ipt2
  635.         NBNEWP = NBELEM
  636.       ELSE
  637. c-dbg        write(ioimp,*) 'HHOPRE: Ajustement MPFHHO'
  638.         ipt2 = MPCHHO
  639.         segact,ipt2*MOD
  640.         NBNEWP = NBELEM - ipt2.num(/2)
  641.         SEGADJ,ipt2
  642. c* Il faut tout decaler par type de face i !
  643.       END IF
  644.       ipoi1 = nbpts
  645.       nbpts = nbpts + NBNEWP
  646.       SEGADJ,MCOORD
  647.       iel2 = 0
  648.       DO i = 1, NCEMAX
  649.         ipt1 = MACHHO(i)
  650.         IF (ipt1.LE.0) GOTO 100
  651.         nel1 = ipt1.num(/2)
  652. c*        nel1 = mleCEL.lect(i+NCEMAX)
  653. c*        jel1 = 1 + mleCEL.lect(i)
  654.         jel1 = 1
  655.         nbn1 = ipt1.num(/1)
  656. c-dbg        write(ioimp,*) 'MACHHO',i,ipt1,nel1,nbn1,iel2,ipoi1
  657.         DO j = jel1, nel1
  658.           jpoi1 = (IDIM+1)*ipoi1
  659.           ipoi1 = ipoi1 + 1
  660.           DO k = 1, IDIM
  661.             r_z = 0.D0
  662.             DO l = 1, nbn1
  663.               lpoi1 = (IDIM+1)*(ipt1.num(l,j)-1)
  664.               r_z = r_z + XCOOR(lpoi1+k)
  665.             END DO
  666.             XCOOR(jpoi1+k) = r_z / nbn1
  667.           END DO
  668.           iel2 = iel2 + 1
  669.           ipt2.num(1,iel2) = ipoi1
  670.         END DO
  671. c-dbg          write(ioimp,*) 'HHOPRE: Verif.',i,iel2,nbchho(i),ipoi1
  672. c---        if (iel2.ne.nbfhho(i)) then
  673. c---          write(ioimp,*) 'HHOPRE(1): inconsistent iel2'
  674. c---        end if
  675.  100    CONTINUE
  676.       END DO
  677.       if (iel2.ne.NCEHHO) then
  678.         iret = 5
  679.         return
  680.       end if
  681.  
  682.       NBNN   = 1
  683.       NBELEM = NFAHHO
  684.       NBSOUS = 0
  685.       NBREF  = 0
  686.       IF (i1_HHO.EQ.1) THEN
  687. c-dbg        write(ioimp,*) 'HHOPRE: Initialisation MPFHHO',NFAHHO
  688.         SEGINI,ipt2
  689.         ipt2.itypel = 1
  690.         MPFHHO = ipt2
  691.         NBNEWP = NBELEM
  692.       ELSE
  693. c-dbg        write(ioimp,*) 'HHOPRE: Ajustement MPFHHO'
  694.         ipt2 = MPFHHO
  695.         segact,ipt2*MOD
  696.         NBNEWP = NBELEM - ipt2.num(/2)
  697.         SEGADJ,ipt2
  698. c* Il faut tout decaler par type de face i !
  699.       END IF
  700.       ipoi1 = nbpts
  701.       nbpts = nbpts + NBNEWP
  702.       SEGADJ,MCOORD
  703.       iel2 = 0
  704.       DO i = idebf, ifinf
  705.         ipt1 = MAFHHO(i)
  706.         IF (ipt1.LE.0) GOTO 200
  707. c*        nel1 = NBFHHO(i)
  708.         nel1 = ipt1.num(/2)
  709. c*        jel1 = 1 + mlent2.lect(i)
  710.         jel1 = 1
  711.         nbn1 = i
  712.         DO j = jel1, nel1
  713.           jpoi1 = (IDIM+1)*ipoi1
  714.           ipoi1 = ipoi1 + 1
  715.           DO k = 1, IDIM
  716.             r_z = 0.D0
  717.             DO l = 1, nbn1
  718.               lpoi1 = (IDIM+1)*(ipt1.num(l,j)-1)
  719.               r_z = r_z + XCOOR(lpoi1+k)
  720.             END DO
  721.             XCOOR(jpoi1+k) = r_z / nbn1
  722.           END DO
  723.           iel2 = iel2 + 1
  724.           ipt2.num(1,iel2) = ipoi1
  725.         END DO
  726. c-dbg          write(ioimp,*) 'HHOPRE: Verif.',i,iel2,nbfhho(i),ipoi1
  727. c---        if (iel2.ne.nbfhho(i)) then
  728. c---          write(ioimp,*) 'HHOPRE(1): inconsistent iel2'
  729. c---        end if
  730.  200    CONTINUE
  731.       END DO
  732.       if (iel2.ne.NFAHHO) then
  733.         iret = 5
  734.         return
  735.       end if
  736.  
  737.       SEGACT,MCOORD*NOMOD
  738.  
  739. C= Remplissage de segments :
  740.       IPOSR = 0
  741.  
  742.       i_z = 0
  743.       CALL HHOLI2('INIT_IPOS',i_z,IPOSR,i_z,iret)
  744.       if (iret.ne.0) return
  745.  
  746.       NMAXR = 0
  747.       DO i = idebf, ifinf
  748.         ipt1 = MAFHHO(i)
  749.         IF (ipt1.GT.0) THEN
  750.           CALL HHOLI2('REMP_IPOS',ipt1,IPOSR,i_z,iret)
  751.           if (iret.ne.0) return
  752.           NMAXR = MAX(NMAXR,i_z)
  753.         END IF
  754.       END DO
  755.       NISFHO = NMAXR
  756.  
  757.       NMAXR = 0
  758.       DO i = 1, NCEMAX
  759.         ipt1 = MACHHO(i)
  760.         IF (ipt1.GT.0) THEN
  761.           CALL HHOLI2('REMP_IPOS',ipt1,IPOSR,i_z,iret)
  762.           if (iret.ne.0) return
  763.           NMAXR = MAX(NMAXR,i_z)
  764.         END IF
  765.       END DO
  766.       NISCHO = NMAXR
  767.  
  768.       i_z = 0
  769.       INDSR = 0
  770.       NMAXR = MAX(NISCHO,NISFHO)
  771.       CALL HHOLI2('INIT_INDS',i_z,NMAXR,INDSR,iret)
  772.       if (iret.ne.0) return
  773.  
  774. c== Remplissage de lentHHO :
  775.       JG = 10
  776.       SEGINI,mlenti
  777.       DO i = 1, JG
  778.         mlenti.lect(i) = -999
  779.       END DO
  780. C= Dimension du probleme :
  781.       mlenti.lect(1) = IDIM
  782. C= Ordre et ddl par face  :
  783.       mlenti.lect(2) = n_o_face
  784.       mlenti.lect(3) = n_d_face
  785. C= Ordre et ddl par cellule :
  786.       mlenti.lect(4) = n_o_cell
  787.       mlenti.lect(5) = n_d_cell
  788. C= Segments de travail :
  789.       mlenti.lect(6) = IPOSR
  790.       mlenti.lect(7) = INDSR
  791. C= Indices utilises ulterieurement :
  792. c-dbg      mlenti.lect( 8) = ...
  793. c-dbg      mlenti.lect( 9) = ...
  794. c-dbg      mlenti.lect(10) = ...
  795.  
  796.       lentHHO = mlenti
  797.  
  798.       SEGSUP,mleCEL,mleSQE
  799.  
  800. c-dbgC= Test independant de la bibliotheque :
  801. c-dbg      write(ioimp,*)
  802. c-dbg      write(ioimp,*) 'HHOPRE - DEBUT TEST_HHO'
  803. c-dbg      CALL TEST_HHO
  804. c-dbg      write(ioimp,*)
  805. c-dbg      write(ioimp,*) 'HHOPRE - FIN TEST_HHO'
  806. c-dbg      write(ioimp,*)
  807.  
  808.       RETURN
  809.       END
  810.  
  811.  
  812.  

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