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

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