Télécharger la plaquette Cast3M


fr en

Télécharger varica.eso

Retour à la liste

Numérotation des lignes : 

varica

  1. C VARICA    SOURCE    MB234859  25/09/08    21:16:12     12358          
  2.  
  3. *____________________________________________________________________
  4. *
  5. *            Calcul d'un champ variable appele par VARI
  6. *
  7. *  ENTREES :
  8. *  ---------
  9. *
  10. *     IPOI1   Pointeur sur un MCHAML ou un CHPOINT
  11. *     IPOI2   Pointeur sur un EVOLUTIO
  12. *     IPMODL  Pointeur sur un MMODEL
  13. *     MICHE    = 1 si on a lu un CHPOINT
  14. *     JEMIL    = 1 A 5 selon le support choisi
  15. *
  16. *  SORTIE :
  17. *  --------
  18. *
  19. *     IRET   Pointeur sur le MCHAML resultat
  20. *            =0 si operation impossible
  21. *
  22. *  Passage aux nouveaux CHAMELEMs par JM CAMPENON LE 05/91
  23. *
  24. *____________________________________________________________________
  25.  
  26.       SUBROUTINE VARICA(IPOI1,IPOI2,IPMODL,IRET,MICHE,JEMIL)
  27.  
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33.  
  34. -INC SMCHAML
  35. -INC SMCHPOI
  36. -INC SMMODEL
  37. -INC SMEVOLL
  38. -INC SMLREEL
  39. -INC SMELEME
  40. -INC SMINTE
  41. -INC SMCOORD
  42.  
  43.       SEGMENT SWORK
  44.          REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
  45.          REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
  46.       ENDSEGMENT
  47.  
  48.       CHARACTER*(LOCOMP) MOTREF,MOTABS
  49.  
  50.       IRET  = 0
  51.       IPOIN1= 0
  52. *
  53. *     On recupere l'objet evolution
  54. *
  55.       MEVOLL = IPOI2
  56.       SEGACT,MEVOLL
  57.       KEVOLL = mevoll.IEVOLL(1)
  58.       SEGACT,KEVOLL
  59.       IF (kevoll.TYPX .NE. 'LISTREEL' .OR.
  60.      &    kevoll.TYPY .NE. 'LISTREEL') THEN
  61.         MOTERR= 'LISTREEL'
  62.         CALL ERREUR(37)
  63.         RETURN
  64.       ENDIF
  65.       MLREE1 = kevoll.IPROGX
  66.       MLREE2 = kevoll.IPROGY
  67.       MOTABS = kevoll.NOMEVX
  68. *
  69.       SEGACT,MLREE1,MLREE2
  70.       NBPOIX = MLREE1.PROG(/1)
  71.       NBPOIY = MLREE2.PROG(/1)
  72. * Petites verifications sur le contenu de l'evolution
  73.       IF (NBPOIX.NE.NBPOIY) THEN
  74.          CALL ERREUR(577)
  75.          RETURN
  76.       ENDIF
  77.       JORDO = 0
  78.       CALL VARIFV(MLREE1.PROG,NBPOIX, JORDO)
  79.       IF (JORDO.EQ.0) THEN
  80.          CALL ERREUR(872)
  81.          RETURN
  82.       ENDIF
  83. *
  84.       IPOIC = IPOI1
  85.       IF (MICHE.EQ.0) GO TO 231
  86. *
  87. *     Traitement du CHPOINT - Recherche du nombre de composantes
  88. *
  89.       MOTREF = MOTABS
  90.  
  91.       MCHPO1 = IPOIC
  92.       SEGACT,MCHPO1
  93.       NSOUP1 = MCHPO1.IPCHP(/1)
  94. *
  95.       DO 329 IA = 1, NSOUP1
  96.         MSOUP1 = MCHPO1.IPCHP(IA)
  97.         SEGACT,MSOUP1
  98.         NC1 = MSOUP1.NOCOMP(/2)
  99.         IF (NC1.EQ.1) GO TO 321
  100. *
  101.  325    CONTINUE
  102.         GOTO 320
  103. *
  104.  321    CONTINUE
  105.         IF (IA.EQ.1) THEN
  106.           MOTREF = MSOUP1.NOCOMP(1)
  107.           GOTO 330
  108.         ENDIF
  109. *
  110.         IF (MOTREF.NE.MSOUP1.NOCOMP(1)) GOTO 325
  111. *
  112.  330    CONTINUE
  113. *
  114.  329  CONTINUE
  115. *
  116.  320  CONTINUE
  117.       IF (MOTREF.EQ.MOTABS) THEN
  118.         IVID = 0
  119.         CALL EXCOPP(IPOI1,MOTABS,NIFOUR,IPOI11,'SCAL',NIFOUR,IVID)
  120.         IF (IERR.NE.0) RETURN
  121.       ELSE
  122.         IVID = 1
  123.         IPOI11 = IPOIC
  124.       ENDIF
  125. *
  126. *     On convertit le CHPOINT en MCHAML
  127. *
  128.       CALL CHAME1(0,IPMODL,IPOI11,' ',IPOIC,JEMIL)
  129.       IF (IVID.EQ.0) CALL DTCHPO(IPOI11)
  130.       IF (IERR.NE.0) RETURN
  131. *
  132. *     Poursuite du traitement pour un MCHAML
  133. *
  134.   231 CONTINUE
  135. *
  136.       MCHEL1 = IPOIC
  137.       SEGACT,MCHEL1
  138.       NINF = MCHEL1.INFCHE(/2)
  139. *
  140. * Activation du modele :
  141. *
  142.       MMODEL = IPMODL
  143.       SEGACT,MMODEL
  144.       NSOUS = mmodel.KMODEL(/1)
  145.       DO ISOUS = 1, NSOUS
  146.         IMODEL = mmodel.KMODEL(ISOUS)
  147.         SEGACT,IMODEL
  148.       ENDDO
  149. *
  150. *     Creation du MCHAML
  151. *
  152.       N1 = NSOUS
  153.       N3 = 6
  154.       L1 = 8
  155.       SEGINI,MCHELM
  156.       mchelm.IFOCHE = IFOUR
  157.       mchelm.TITCHE = 'SCALAIRE'
  158. *
  159. *     Boucle sur les sous zone du MCHAML
  160. *
  161.       DO 100 ISOUS = 1, NSOUS
  162. *
  163. *        Mise en concordance des pointeurs de maillage
  164. *
  165.          MELEME = MCHEL1.IMACHE(ISOUS)
  166.          DO 150 IO = 1, NSOUS
  167.            imodel = mmodel.KMODEL(IO)
  168.            IF (imodel.IMAMOD.EQ.MELEME .AND.
  169.      &         imodel.CONMOD.EQ.MCHEL1.CONCHE(ISOUS)) GOTO 160
  170.  150     CONTINUE
  171.          CALL ERREUR(472)
  172.          GOTO 9910
  173. *
  174.  160     CONTINUE
  175. *
  176. *        Recherche de la composante
  177. *
  178.          MCHAM1 = MCHEL1.ICHAML(ISOUS)
  179.          SEGACT,MCHAM1
  180. *
  181. *        Recherche du nom MOTABS
  182. *        pour les champ a une composante pas de verif. de MOTABS
  183. *
  184.          ncomp1 = MCHAM1.NOMCHE(/2)
  185.          IF (ncomp1.EQ.1) THEN
  186.            IPLAC = 1
  187.          ELSE
  188.            IPLAC = 0
  189.            CALL PLACE (MCHAM1.NOMCHE,ncomp1,IPLAC,MOTABS)
  190. *
  191. *           On a pas trouve la composante
  192. *
  193.            IF (IPLAC.EQ.0) THEN
  194.              MOTERR(1:8) = MOTABS
  195.              CALL ERREUR(243)
  196.              GOTO 9920
  197.            ENDIF
  198.          ENDIF
  199. *
  200.          IF (MCHAM1.TYPCHE(IPLAC).NE.'REAL*8') THEN
  201.            MOTERR(1:4) = 'VARI'
  202.            MOTERR(5:8) = MCHAM1.NOMCHE(IPLAC)
  203.            CALL ERREUR(335)
  204.            GOTO 9920
  205.          ENDIF
  206. *
  207. *        Information sur l'element fini
  208. *
  209.          MELE = imodel.NEFMOD
  210. *
  211. *        On recupere le nombre de points support NBPGA1 pour l'ancien ch
  212. *
  213.          MINTE1 = 0
  214.          IF (MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
  215. *
  216. *           La sous zone est aux noeuds
  217. *
  218.            MINTE1 = imodel.INFMOD(3)
  219.          ELSE
  220.            MINTE1 = MCHEL1.INFCHE(ISOUS,4)
  221.          ENDIF
  222.          SEGACT,MINTE1
  223.          NBPGA1 = MINTE1.SHPTOT(/3)
  224. *
  225. *        On recupere le nombre de points support NBPGAU du nouveau champ
  226. *
  227.          MINTE  = imodel.INFMOD(2+JEMIL)
  228.          MELGEO = imodel.INFELE(14)
  229.          SEGACT,MINTE
  230.          NBPGAU = minte.SHPTOT(/3)
  231. *
  232. **         IMACHE(ISOUS) = MELEME
  233.          IMACHE(ISOUS) = MCHEL1.IMACHE(ISOUS)
  234.          CONCHE(ISOUS) = MCHEL1.CONCHE(ISOUS)
  235.  
  236.          DO 191 IP = 1,NINF
  237.            INFCHE(ISOUS,IP) = MCHEL1.INFCHE(ISOUS,IP)
  238.  191     CONTINUE
  239.          INFCHE(ISOUS,4) = MINTE
  240.          INFCHE(ISOUS,6) = JEMIL
  241. *
  242. *        Creation du MCHAML de la sous zone
  243. *
  244.          N2 = 1
  245.          SEGINI,MCHAML
  246.          ICHAML(ISOUS) = MCHAML
  247.          mchaml.TYPCHE(1) = 'REAL*8'
  248.          mchaml.NOMCHE(1) = 'SCAL'
  249. *
  250.          MELVA1 = MCHAM1.IELVAL(IPLAC)
  251.          SEGACT,MELVA1
  252.          N1PTE1 = MELVA1.VELCHE(/1)
  253.          N1EL1  = MELVA1.VELCHE(/2)
  254. *
  255. *        taille du nouveau melval/chamelem
  256. *
  257.          IF (N1PTE1.EQ.1) THEN
  258.            N1PTEL = 1
  259.          ELSE
  260.            N1PTEL = NBPGAU
  261.          ENDIF
  262.          N1EL   = N1EL1
  263.          N2PTEL = 0
  264.          N2EL   = 0
  265.  
  266.          SEGINI,MELVAL
  267.          mchaml.IELVAL(1) = MELVAL
  268. *
  269. *        Traitement immediat si champ constant
  270. *
  271.          IF (N1PTE1.EQ.1) THEN
  272.             DO 4120 IEL = 1, N1EL
  273.                XTT1 = MELVA1.VELCHE(1,IEL)
  274.                CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  275.      &                     XTT1, YTT1)
  276.                melval.VELCHE(1,IEL) = YTT1
  277.  4120       CONTINUE
  278. *
  279.          ELSE
  280. *
  281. *              Meme support (N1PTEL = NBPGAU = NBPGA1 = N1PTE1)
  282. *
  283.            IF (MINTE.EQ.MINTE1) THEN
  284. *
  285.              DO 3120 IEL = 1, N1EL
  286.  
  287.                DO 3121 IGAU = 1, N1PTE1
  288.                  XTT1 = MELVA1.VELCHE(IGAU,IEL)
  289.                  CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  290.      &                       XTT1,YTT1)
  291.                  melval.VELCHE(IGAU,IEL) = YTT1
  292.  3121          CONTINUE
  293.  3120        CONTINUE
  294. *
  295. *              Support different
  296. *
  297.            ELSE
  298. *
  299.              CALL QUEDIM(MELGEO,JDIM)
  300.              IF (JDIM.EQ.0) THEN
  301.                CALL ERREUR(29)
  302.                GOTO 9940
  303.              ENDIF
  304. *
  305.              N1PAUX = N1PTE1
  306. *        Pour les COQ4, le nb de pt de GAUSS vaut 5, mais on
  307. *        ne prend que les 4 premiers (le 5ieme sert uniquement
  308. *        au cisaillement)
  309.              IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX = 4
  310. *
  311. *            On recupere le nombre d'elements
  312. *
  313.              SEGACT,MELEME
  314.              NBNN   = meleme.NUM(/1)
  315.              NBELEM = meleme.NUM(/2)
  316. *
  317.              SEGINI,SWORK
  318.  
  319.              DO 3130 IEL = 1, NBELEM
  320.  
  321.                DO 3131 IGAU = 1, N1PTE1
  322.                  XTT1 = MELVA1.VELCHE(IGAU,IEL)
  323.                  CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,
  324.      &                       XTT1,YTT1)
  325.                  VAL1(IGAU) = YTT1
  326.  3131          CONTINUE
  327.  
  328.                CALL DOXE(XCOOR,IDIM,NBNN,meleme.NUM,IEL,XE)
  329.                KERRE = JDIM
  330.                CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,SWORK,
  331.      &                     IPOIN1,KERRE)
  332.                IF (KERRE.NE.0) THEN
  333.                  CALL ERREUR(KERRE)
  334.                  GOTO 9950
  335.                ENDIF
  336. *
  337.                DO 3132 IGAU = 1, N1PTEL
  338.                  melval.VELCHE(IGAU,IEL) = VAL2(IGAU)
  339.  3132          CONTINUE
  340.  3130        CONTINUE
  341.  
  342.              SEGSUP,SWORK
  343. *
  344.            ENDIF
  345. *
  346.          ENDIF
  347. *
  348.  100  CONTINUE
  349. *
  350.       IRET = MCHELM
  351.       RETURN
  352. *
  353. *     Erreur dans une sous zone / desactivation et retour
  354. *
  355.  9950 CONTINUE
  356.       SEGSUP,SWORK
  357.  9940 CONTINUE
  358.       SEGSUP,MELVAL,MCHAML
  359.  9930 CONTINUE
  360. *
  361.  9920 CONTINUE
  362. *
  363.  9910 CONTINUE
  364.       SEGSUP,MCHELM
  365.       IRET = 0
  366.  
  367.       END
  368.  
  369.  
  370.  
  371.  
  372.  
  373.  

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