Télécharger la plaquette Cast3M


fr en

Télécharger elchpo.eso

Retour à la liste

Numérotation des lignes : 

elchpo

  1. C ELCHPO    SOURCE    CB215821  20/11/25    13:27:10     10792          
  2.  
  3. C=======================================================================
  4. c  fonction:
  5. c  sous routine pour arranger un chpo qui a souffert apres elim
  6. c
  7. c  arguments:
  8. c  ip1 (e/s) pointeur sur le champ par point / ACTIF en SORTIE
  9. c   
  10. c
  11. c  variables:
  12. c * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour
  13. c          le jieme noeud du tableau igeo .
  14. c           - inco(nnin) contient le nom des nnin inconnues differentes
  15. c           - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ
  16. c          existe pour le jieme noeud du tableau igeo .
  17. c           - igeo(i) est le numero a mettre dans un objet meleme pour
  18. c          referencer le ieme noeud .
  19. c
  20. C=  A. DE GAYFFIER, le 7 juillet 1994.                                 =
  21. C=======================================================================
  22.  
  23.       SUBROUTINE ELCHPO(IP1,iratt)
  24.  
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8(A-H,O-Z)
  27.  
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC SMCHPOI
  32. -INC SMELEME
  33. -INC SMCOORD
  34. -INC TMTRAV
  35.  
  36.       SEGMENT MTR1
  37.         CHARACTER*(LOCOMP) TINCO(NNIN)
  38.       ENDSEGMENT
  39.       SEGMENT MTR2
  40.         INTEGER TIBIN(NNINR,NNNOER)
  41.         REAL*8 TBB(NNINR,NNNOER)
  42.       ENDSEGMENT
  43.       SEGMENT MTR3
  44.         INTEGER TGEO(TGEOD)
  45.       ENDSEGMENT
  46.       SEGMENT MTR3I
  47.         INTEGER ITGEO(ITGEOD)
  48.       ENDSEGMENT
  49.       SEGMENT MTR4
  50.         INTEGER THARM(0)
  51.       ENDSEGMENT
  52.       SEGMENT MTR5
  53.         INTEGER ICO(NC)
  54.       ENDSEGMENT
  55.       INTEGER TGEOD
  56.  
  57.       PARAMETER (Epsi=1.D-30)
  58.       CHARACTER*(LOCOMP) cmot
  59.       LOGICAL FLAG
  60.  
  61.       MCHPOI=IP1
  62.       SEGACT,MCHPOI
  63.  
  64. C    verification de la compatibilite des natures
  65.       NAT=JATTRI(/1)
  66.       NATU=NAT
  67.       IF (NATU.GT.0) THEN
  68.         NATU=JATTRI(1)
  69.       ENDIF
  70. C    la nature est indeterminee on ne peut rien faire
  71.       IF (NATU.EQ.0) THEN
  72.         Iratt=2
  73.         RETURN
  74.       ENDIF
  75.  
  76. c    on eclate le champ par point dans le segment mtrav
  77.       NNINR=10
  78.       NNNOER=10000
  79.       NNIN=0
  80.       NNNOE=0
  81.       TGEOD =1000
  82.       ITGEOD=1000
  83.       SEGINI,MTR1,MTR2,MTR3,MTR3I,MTR4
  84.  
  85. c boucle sur les msoupo
  86. c
  87.       DO 60 i=1,IPCHP(/1)
  88.         MSOUPO=IPCHP(i)
  89.         SEGACT,MSOUPO
  90.         MPOVAL=IPOVAL
  91.         IF (MPOVAL.EQ.0) THEN
  92.           SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4
  93.           RETURN
  94.         ENDIF
  95. c
  96. c     boucle sur les composantes
  97. c     on remplit tinco avec le nom des composantes
  98.         NC=NOCOMP(/2)
  99.         SEGINI,MTR5
  100.         DO 20 j=1,NC
  101.           cmot=NOCOMP(j)
  102.           DO k=1,NNIN
  103.             IF (TINCO(k).EQ.cmot) THEN
  104.               ICO(j)=k
  105.               GOTO 20
  106.             ENDIF
  107.           ENDDO
  108. c         il y une inconnue de plus dans tinco
  109.           NNIN=NNIN+1
  110.           ICO(j)=NNIN
  111.           SEGADJ,MTR1
  112.           TINCO(NNIN)=cmot
  113.           THARM(**)=NOHARM(j)
  114.  20     CONTINUE
  115. c
  116. c      boucle sur les noeuds du msoupo
  117.         MELEME=IGEOC
  118.         SEGACT,MELEME
  119.         NOE=NUM(/2)
  120.         DO 40 j=1,NOE
  121. c         pour savoir si le noeud j appartient a geo
  122.           jnoe=NUM(1,j)
  123.           if (jnoe.gt.ITGEOD) then
  124.            ITGEOD=jnoe*2
  125.            segadj mtr3i
  126.           endif
  127.           IF (itgeo(jnoe).ne.0) goto 40
  128. c     le noeud n'etait pas dans la pile
  129.           NNNOE=NNNOE+1
  130.           if (nnnoe.gt.tgeod) then
  131.            tgeod=nnnoe*2
  132.            segadj mtr3
  133.           endif
  134.           TGEO(nnnoe)=jnoe
  135.           itgeo(jnoe)=nnnoe
  136.  40     CONTINUE
  137. c
  138. c encore une boucle sur les noeuds pour remplir tbb avec les valeurs
  139. c  ico et ino servent pour retrouver les numeros dans tgeo et tinco
  140.         if (nnin.gt.nninr) then
  141.           nninr=nnin+10
  142.         endif
  143.         if (nnnoe.gt.nnnoer) then
  144.           nnnoer=nnnoe+10000
  145.         endif
  146.         if (nninr.ne.tibin(/1).or.nnnoer.ne.tibin(/2)) SEGADJ,MTR2
  147.         SEGACT,MPOVAL
  148.         DO k=1,NC
  149.           FLAG=.TRUE.
  150.           icok=ICO(k)
  151.           DO j=1,NUM(/2)
  152. c             il s'agit d'un point double
  153.             inoj=itgeo(num(1,j))
  154.             IF (TIBIN(icok,inoj).NE.0) THEN
  155.               IF (NATU.EQ.2) THEN
  156. c              le champ est discret on additionne
  157.                 TBB(icok,inoj)=TBB(icok,inoj)+VPOCHA(j,k)
  158.               ELSE
  159. c              le champ est diffus il faut l'egalite
  160.                 V1=TBB(icok,inoj)
  161.                 V2=VPOCHA(j,k)
  162.                 VMOY=0.5*(V1+V2)+Epsi
  163. c                test sur la difference relative
  164. c                on commence par chercher un ordre de grandeur de la
  165. c                composante sur la sous zone pour faire un test sur la
  166. c                valeur absolue de la difference
  167.                 IF (ABS(V2-V1).GT.(1.D-4*ABS(VMOY))) THEN
  168.                   IF (FLAG) THEN
  169.                     THEMAX=0.
  170.                     DO l=1,NUM(/2)
  171.                       THEMAX=MAX(ABS(VPOCHA(l,k)),THEMAX)
  172.                     ENDDO
  173.                     FLAG=.FALSE.
  174.                   ENDIF
  175. c             il n'y a pas egalite : erreur
  176.                   IF (ABS(V2-V1).GT.(1.D-4*THEMAX)) THEN
  177.                     Iratt=2
  178. c  les lignes suivantes sont en commentaire de facon
  179. c  a traiter quand meme les champ par point diffus dont les
  180. c  valeurs sont distinctes: on prend la moyenne
  181. c                   SEGSUP,mtr1,mtr2,mtr3,mtr4,mtr5,mtr6
  182. c                   RETURN
  183.                   ENDIF
  184.                 ENDIF
  185. c      on affecte la valeur moyenne dans tous les cas
  186.                 TBB(icok,inoj)=VMOY
  187.               ENDIF
  188.             ELSE
  189.               TBB(icok,inoj)=VPOCHA(j,k)
  190.               TIBIN(icok,inoj)=1
  191.             ENDIF
  192.           ENDDO
  193.         ENDDO
  194.         SEGSUP,MTR5
  195.  60   CONTINUE
  196.  
  197. C= Remplissage du segment MTRAV (ITRAV)
  198.       SEGINI,MTRAV
  199.       DO i=1,NNIN
  200.         INCO(i)=TINCO(i)
  201. C*OF    NHAR(i)=THARM(i)
  202.       ENDDO
  203. C*OF IF temporaire en attendant operateur remplacant procedure creer_3D
  204.       IF (IFOMOD.EQ.1) THEN
  205.         DO i=1,NNIN
  206.           NHAR(i)=THARM(i)
  207.         ENDDO
  208.       ENDIF
  209.       DO j=1,NNNOE
  210.         IGEO(j)=TGEO(j)
  211.         DO i=1,NNIN
  212.           BB(i,j)=TBB(i,j)
  213.           IBIN(i,j)=TIBIN(i,j)
  214.         ENDDO
  215.       ENDDO
  216.       ITRAV=MTRAV
  217.  
  218. c     reconstuction de la partition
  219.       CALL CRECHP(ITRAV,ICHP)
  220. c     on ajuste le contenu du chapeau
  221.       MCHPO1=ICHP
  222.       SEGACT,MCHPO1
  223.       NSOUPO=MCHPO1.IPCHP(/1)
  224.       SEGADJ,MCHPOI
  225.       DO i=1,NSOUPO
  226.         IPCHP(i)=MCHPO1.IPCHP(i)
  227.       ENDDO
  228.  
  229.       SEGSUP,MCHPO1
  230.       SEGSUP,MTR1,MTR2,MTR3,MTR3I,MTR4,MTRAV
  231.  
  232.       RETURN
  233.       END
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  

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